import Data.TreeSeq.Strict (Trees, Tree(..))
-- * Type 'Zipper'
-type Zipper k a = NonEmpty (Cursor k a)
+type Zipper a = NonEmpty (Cursor a)
-- | Return a 'Zipper' starting at the given 'Tree'.
-zipper :: Tree k a -> Zipper k a
+zipper :: Tree a -> Zipper a
zipper t = Cursor mempty t mempty :| []
-- | Return a 'Zipper' starting at the left-most 'Tree' of the given 'Trees'.
-zippers :: Trees k a -> [Zipper k a]
+zippers :: Trees a -> [Zipper a]
zippers ts =
case Seq.viewl ts of
EmptyL -> empty
l :< ls -> pure $ Cursor mempty l ls :| []
-- | Return the 'Cursor' after zipping the given 'Zipper' upto its last parent.
-root :: Zipper k a -> Cursor k a
+root :: Zipper a -> Cursor a
root = NonEmpty.head . List.last . runAxis axis_ancestor_or_self
-- | Like 'root', but concatenate the 'Cursor' into a 'Trees'.
-roots :: Zipper k a -> Trees k a
+roots :: Zipper a -> Trees a
roots z = cursor_preceding_siblings <> (cursor_self <| cursor_following_siblings)
where Cursor{..} = root z
-- | Return the keys within the 'TreeN' nodes
-- leading to the current 'Cursor' of the given 'Zipper'.
-zipath :: Zipper k x -> [k]
+zipath :: Zipper a -> [a]
zipath z =
List.reverse $
NonEmpty.toList z >>= \c ->
case cursor_self c of
- TreeN k _ -> [k]
- Tree0{} -> []
+ Tree a _ -> [a]
-- | Return the 'Tree's selected by the given 'Axis' from the given 'Zipper'.
-select :: Axis k a -> Zipper k a -> [Tree k a]
+select :: Axis a -> Zipper a -> [Tree a]
select axis z = cursor_self . NonEmpty.head <$> runAxis axis z
-- | Return the filtered values selected by the given 'Axis' from the given 'Zipper'.
-filter :: Axis k a -> (Zipper k a -> Maybe b) -> Zipper k a -> [b]
+filter :: Axis a -> (Zipper a -> Maybe b) -> Zipper a -> [b]
filter axis f z = f `mapMaybe` runAxis axis z
-- ** Type 'Cursor'
-data Cursor k a
+data Cursor a
= Cursor
- { cursor_preceding_siblings :: Trees k a
- , cursor_self :: Tree k a
- , cursor_following_siblings :: Trees k a
+ { cursor_preceding_siblings :: Trees a
+ , cursor_self :: Tree a
+ , cursor_following_siblings :: Trees a
} deriving (Eq, Show, Typeable)
-- | Return the current 'Cursor' of a 'Zipper'.
-cursor :: Zipper k a -> Cursor k a
+cursor :: Zipper a -> Cursor a
cursor = NonEmpty.head
-- | Set the current 'Cursor' of a 'Zipper'.
-setCursor :: Zipper k a -> Cursor k a -> Zipper k a
+setCursor :: Zipper a -> Cursor a -> Zipper a
setCursor (_c :| cs) c = c :| cs
-- | Return the 'Tree' currently under the 'Cursor'.
-current :: Zipper k a -> Tree k a
+current :: Zipper a -> Tree a
current (Cursor _ t _ :| _) = t
-- ** Type 'Axis'
-type Axis k a = AxisAlt [] k a
+type Axis a = AxisAlt [] a
-runAxis :: Axis k a -> Zipper k a -> [Zipper k a]
+runAxis :: Axis a -> Zipper a -> [Zipper a]
runAxis = runKleisli
-- ** Type 'AxisAlt'
-- | Like 'Axis', but generalized with 'Alternative'.
--
-- Useful to return a 'Maybe' instead of a list.
-type AxisAlt f k a = Kleisli f (Zipper k a) (Zipper k a)
+type AxisAlt f a = Kleisli f (Zipper a) (Zipper a)
-runAxisAlt :: AxisAlt f k a -> Zipper k a -> f (Zipper k a)
+runAxisAlt :: AxisAlt f a -> Zipper a -> f (Zipper a)
runAxisAlt = runKleisli
-- ** Axis @repeat@
-- | Collect all 'Zipper's along a given axis,
-- including the first 'Zipper'.
-axis_repeat :: AxisAlt Maybe k a -> Axis k a
+axis_repeat :: AxisAlt Maybe a -> Axis a
axis_repeat f = Kleisli $ \z -> z : maybe [] (runAxis $ axis_repeat f) (runAxisAlt f z)
-- | Collect all 'Zipper's along a given axis,
-- excluding the starting 'Zipper'.
-axis_repeat_without_self :: AxisAlt Maybe k a -> Axis k a
+axis_repeat_without_self :: AxisAlt Maybe a -> Axis a
axis_repeat_without_self f = Kleisli $ \z -> maybe [] (runAxis $ axis_repeat f) (runAxisAlt f z)
-- ** Axis @filter@
-axis_filter :: Axis k a -> (Zipper k a -> Bool) -> Axis k a
+axis_filter :: Axis a -> (Zipper a -> Bool) -> Axis a
axis_filter axis f = Kleisli $ \z -> List.filter f (runAxis axis z)
infixl 5 `axis_filter`
-axis_filter_current :: Axis k a -> (Tree k a -> Bool) -> Axis k a
+axis_filter_current :: Axis a -> (Tree a -> Bool) -> Axis a
axis_filter_current axis f = Kleisli $ \z -> List.filter (f . current) (runAxis axis z)
infixl 5 `axis_filter_current`
-- ** Axis @first@
-axis_first :: Axis k a -> Axis k a
+axis_first :: Axis a -> Axis a
axis_first axis = Kleisli $ List.take 1 . runAxis axis
-- ** Axis @last@
-axis_last :: Axis k a -> Axis k a
+axis_last :: Axis a -> Axis a
axis_last axis = Kleisli $ List.take 1 . List.reverse . runAxis axis
-- ** Axis @at@
-axis_at :: Alternative f => Axis k a -> Int -> AxisAlt f k a
+axis_at :: Alternative f => Axis a -> Int -> AxisAlt f a
axis_at axis i = Kleisli $ \z ->
case List.drop i $ runAxis axis z of
[] -> empty
infixl 5 `axis_at`
-- ** Axis @self@
-axis_self :: Applicative f => AxisAlt f k a
+axis_self :: Applicative f => AxisAlt f a
axis_self = Kleisli pure
-- ** Axis @child@
-axis_child :: Axis k a
+axis_child :: Axis a
axis_child =
axis_child_first >>>
axis_repeat axis_following_sibling_nearest
-axis_child_lookup_first :: Alternative f => (k -> Bool) -> AxisAlt f k a
-axis_child_lookup_first fk = Kleisli $ listHead . runAxis (axis_child_lookup fk)
+axis_child_lookup_first :: Alternative f => (a -> Bool) -> AxisAlt f a
+axis_child_lookup_first fa = Kleisli $ listHead . runAxis (axis_child_lookup fa)
-axis_child_lookup :: (k -> Bool) -> Axis k a
-axis_child_lookup fk = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
- let ns = nodesTree t in
- (<$> Seq.findIndicesL flt ns) $ \i ->
+axis_child_lookup :: (a -> Bool) -> Axis a
+axis_child_lookup f = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
+ let ns = subTrees t in
+ (<$> Seq.findIndicesL (f . unTree) ns) $ \i ->
let (ps, ps') = Seq.splitAt i ns in
case Seq.viewl ps' of
EmptyL -> undefined
l :< ls -> Cursor ps l ls :| NonEmpty.toList z
- where
- flt = \case
- TreeN k _ -> fk k
- Tree0{} -> False
-axis_child_first :: Alternative f => AxisAlt f k a
+axis_child_first :: Alternative f => AxisAlt f a
axis_child_first = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
- case Seq.viewl $ nodesTree t of
+ case Seq.viewl $ subTrees t of
EmptyL -> empty
l :< ls -> pure $ Cursor mempty l ls :| NonEmpty.toList z
-axis_child_last :: Alternative f => AxisAlt f k a
+axis_child_last :: Alternative f => AxisAlt f a
axis_child_last = Kleisli $ \z@(Cursor _ps t _fs :| _) ->
- case Seq.viewr $ nodesTree t of
+ case Seq.viewr $ subTrees t of
EmptyR -> empty
rs :> r -> pure $ Cursor rs r mempty :| NonEmpty.toList z
-- ** Axis @ancestor@
-axis_ancestor :: Axis k a
+axis_ancestor :: Axis a
axis_ancestor = axis_repeat_without_self axis_parent
-axis_ancestor_or_self :: Axis k a
+axis_ancestor_or_self :: Axis a
axis_ancestor_or_self = axis_repeat axis_parent
-axis_root :: Alternative f => AxisAlt f k a
+axis_root :: Alternative f => AxisAlt f a
axis_root = Kleisli $ pure . List.last . runAxis axis_ancestor_or_self
-- ** Axis @descendant@
-axis_descendant_or_self :: Axis k a
+axis_descendant_or_self :: Axis a
axis_descendant_or_self =
Kleisli $ collect_child []
where
(runAxisAlt axis_following_sibling_nearest z)
) z
-axis_descendant_or_self_reverse :: Axis k a
+axis_descendant_or_self_reverse :: Axis a
axis_descendant_or_self_reverse = Kleisli go
where go z = z : List.concatMap go (List.reverse $ runAxis axis_child z)
-axis_descendant :: Axis k a
+axis_descendant :: Axis a
axis_descendant = Kleisli $ List.tail . runAxis axis_descendant_or_self
-- ** Axis @preceding@
-axis_preceding_sibling :: Axis k a
+axis_preceding_sibling :: Axis a
axis_preceding_sibling = axis_repeat_without_self axis_preceding_sibling_nearest
-axis_preceding_sibling_nearest :: Alternative f => AxisAlt f k a
+axis_preceding_sibling_nearest :: Alternative f => AxisAlt f a
axis_preceding_sibling_nearest = Kleisli $ \(Cursor ps t fs :| cs) ->
case Seq.viewr ps of
EmptyR -> empty
rs :> r -> pure $ Cursor rs r (t <| fs) :| cs
-axis_preceding_sibling_farthest :: Alternative f => AxisAlt f k a
+axis_preceding_sibling_farthest :: Alternative f => AxisAlt f a
axis_preceding_sibling_farthest = Kleisli $ \z@(Cursor ps t fs :| cs) ->
case Seq.viewl (ps |> t) of
EmptyL -> pure z
l :< ls -> pure $ Cursor mempty l (ls<>fs) :| cs
-axis_preceding :: Axis k a
+axis_preceding :: Axis a
axis_preceding =
axis_ancestor_or_self >>>
axis_preceding_sibling >>>
axis_descendant_or_self_reverse
-- ** Axis @following@
-axis_following_sibling :: Axis k a
+axis_following_sibling :: Axis a
axis_following_sibling = axis_repeat_without_self axis_following_sibling_nearest
-axis_following_sibling_nearest :: Alternative f => AxisAlt f k a
+axis_following_sibling_nearest :: Alternative f => AxisAlt f a
axis_following_sibling_nearest = Kleisli $ \(Cursor ps t fs :| cs) ->
case Seq.viewl fs of
EmptyL -> empty
l :< ls -> pure $ Cursor (ps |> t) l ls :| cs
-axis_following_sibling_farthest :: Alternative f => AxisAlt f k a
+axis_following_sibling_farthest :: Alternative f => AxisAlt f a
axis_following_sibling_farthest = Kleisli $ \z@(Cursor ps t fs :| cs) ->
case Seq.viewr (t <| fs) of
EmptyR -> pure z
rs :> r -> pure $ Cursor (ps<>rs) r mempty :| cs
-axis_following :: Axis k a
+axis_following :: Axis a
axis_following =
axis_ancestor_or_self >>>
axis_following_sibling >>>
axis_descendant_or_self
-- ** Axis @parent@
-axis_parent :: Alternative f => AxisAlt f k a
+axis_parent :: Alternative f => AxisAlt f a
axis_parent = Kleisli $ \(Cursor ps t fs :| cs) ->
case cs of
- Cursor ps' (TreeN k _) fs' : cs' ->
- pure $ Cursor ps' (TreeN k $ (ps |> t) <> fs) fs' :| cs'
+ Cursor ps' (Tree a _) fs' : cs' ->
+ pure $ Cursor ps' (Tree a $ (ps |> t) <> fs) fs' :| cs'
_ -> empty
-- * Utilities
-nodesTree :: Tree k a -> Trees k a
-nodesTree Tree0{} = mempty
-nodesTree (TreeN _k ts) = ts
-
listHead :: Alternative f => [a] -> f a
listHead [] = empty
listHead (a:_) = pure a
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence ((|>))
-import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Data.TreeMap.Strict (TreeMap(..))
-import Data.TreeSeq.Strict (Tree(..))
+import Data.TreeSeq.Strict (Tree(..), tree0)
import qualified Control.Monad.Trans.State as S
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Strict.Maybe as Strict
-import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
import qualified Data.TreeMap.Strict as TreeMap
--- import qualified Data.TreeSeq.Strict as Tree
+-- import qualified Data.TreeSeq.Strict as TreeSeq
import Language.DTC.Document
pathFromWords :: Words -> Maybe PathWord
pathFromWords ws =
case ws >>= unSpace of
- p:ps | not (Text.null p) -> Just (TreeMap.path p ps)
+ p:ps | not (TL.null p) -> Just (TreeMap.path p ps)
_ -> Nothing
where
unSpace = \case
-- * Class 'Anchorify'
class Anchorify a where
anchorify :: a -> S.State State a
-instance Anchorify (Tree k a) => Anchorify [Tree k a] where
+instance Anchorify (Tree a) => Anchorify [Tree a] where
anchorify = mapM anchorify
-instance Anchorify (Tree BodyKey BodyValue) where
+instance Anchorify Body where
+ anchorify = mapM anchorify
+instance Anchorify (Tree BodyNode) where
anchorify = \case
- Tree0 v -> Tree0 <$> anchorify v
- TreeN k v ->
- case k of
+ Tree n ts ->
+ case n of
Section{..} -> do
before@State{state_section} <- S.get
S.put before{state_section = pos}
- t <- TreeN <$> anchorify k <*> anchorify v
+ t <- Tree <$> anchorify n <*> anchorify ts
after <- S.get
S.put after{state_section}
return t
-instance Anchorify Body where
- anchorify = mapM anchorify
-instance Anchorify BodyKey where
+ _ -> Tree <$> anchorify n <*> anchorify ts
+instance Anchorify BodyNode where
anchorify = \case
Section{..} ->
Section pos attrs
<$> anchorify title
<*> pure aliases
-instance Anchorify BodyValue where
- anchorify = \case
d@ToC{} -> pure d
d@ToF{} -> pure d
d@Index{} -> pure d
Figure{..} ->
Figure pos attrs type_
- <$> anchorify title
+ <$> anchorify mayTitle
<*> anchorify blocks
References{..} ->
References pos attrs
Para{..} -> Para pos attrs <$> anchorify para
OL{..} -> OL pos attrs <$> anchorify items
UL{..} -> UL pos attrs <$> anchorify items
- Artwork{..} -> Artwork pos attrs <$> anchorify art
+ Quote{..} -> Quote pos attrs type_ <$> anchorify blocks
+ d@Artwork{} -> pure d
d@Comment{} -> pure d
instance Anchorify Para where
anchorify ls = do
go :: Lines -> S.State State Lines
go t =
case t of
- Tree0{} -> return t
- TreeN k ts ->
- TreeN
- <$> (case k of
+ Tree n ts ->
+ Tree
+ <$> (case n of
Note{..} -> do
State{..} <- S.get
let notes = Map.findWithDefault [] state_section state_notes
S.modify $ \s -> s{state_rrefs=
Map.insert to (anch:anchs) state_rrefs}
return Rref{anchor=Just anch, to}
- _ -> return k)
+ _ -> return n)
<*> traverse go ts
instance Anchorify Reference where
anchorify = return
-instance Anchorify Artwork where
- anchorify = return
indexifyLines :: Lines -> S.State State Para
indexifyLines = \case
- Tree0 a -> indexifyPlain a
- TreeN k@Iref{term} ts
+ Tree n@Iref{term} ts
| Just words <- pathFromWords term -> do
State{state_irefs, state_section} <- S.get
case TreeMap.lookup words state_irefs of
Strict.Nothing ->
- Seq.singleton . TreeN k . join
+ Seq.singleton . Tree n . join
<$> traverse indexifyLines ts
Strict.Just anchs -> do
let count = case anchs of [] -> def; Anchor{count=c}:_ -> succNat1 c
let anch = Anchor{count, section=state_section}
S.modify $ \s -> s{state_irefs=
TreeMap.insert const words (anch:anchs) state_irefs}
- Seq.singleton . TreeN Iref{term, anchor=Just anch} . join
+ Seq.singleton . Tree Iref{term, anchor=Just anch} . join
<$> traverse indexifyLines ts
- TreeN k ts ->
- Seq.singleton . TreeN k . join
- <$> traverse indexifyLines ts
-
-indexifyPlain :: LineValue -> S.State State Para
-indexifyPlain = \case
- BR -> pure $ Seq.singleton $ Tree0 BR
- Plain p -> do
+ Tree BR _ -> pure $ Seq.singleton $ tree0 BR
+ Tree (Plain p) _ -> do
State{..} <- S.get
let (irefs,ts) = indexifyWords state_section state_irefs (wordify p)
S.modify $ \s -> s{state_irefs=irefs}
return ts
+ Tree n ts ->
+ Seq.singleton . Tree n . join
+ <$> traverse indexifyLines ts
indexifyWords :: Pos -> Irefs -> Words -> (Irefs, Para)
indexifyWords section = go mempty
case inp of
[] -> (irefs, acc)
Space : next ->
- go (acc |> Tree0 (Plain " ")) irefs next
+ go (acc |> tree0 (Plain " ")) irefs next
Word w : next ->
case goWords irefs [] inp of
- Nothing -> go (acc |> Tree0 (Plain w)) irefs next
+ Nothing -> go (acc |> tree0 (Plain w)) irefs next
Just (anch, ls, ns, rs) ->
let term = List.reverse ls in
- let lines = Seq.fromList $ Tree0 . Plain . plainifyWord <$> term in
- go (acc |> TreeN Iref{term, anchor=Just anch} lines) rs ns
+ let lines = Seq.fromList $ tree0 . Plain . plainifyWord <$> term in
+ go (acc |> Tree Iref{term, anchor=Just anch} lines) rs ns
goWords ::
Irefs ->
Words -> Words ->
Just (anch, ls, ns, TreeMap $
Map.insert w nod{TreeMap.node_descendants = rs} irefsByWord)
-wordify :: Text -> Words
+wordify :: TL.Text -> Words
wordify = List.reverse . go []
where
- go :: Words -> Text -> Words
+ go :: Words -> TL.Text -> Words
go acc t =
- case Text.span Char.isAlphaNum t of
+ case TL.span Char.isAlphaNum t of
("",_) ->
- case Text.span Char.isSpace t of
+ case TL.span Char.isSpace t of
("",_) ->
- case Text.uncons t of
+ case TL.uncons t of
Nothing -> acc
- Just (c,r) -> go (Word (Text.singleton c) : acc) r
+ Just (c,r) -> go (Word (TL.singleton c) : acc) r
(_s,r) -> go (Space : acc) r
(w,r) -> go (Word w : acc) r
-plainifyWord :: WordOrSpace -> Text
+plainifyWord :: WordOrSpace -> TL.Text
plainifyWord = \case
Word w -> w
Space -> " "
-plainifyWords :: Words -> Text
-plainifyWords = Text.concat . (plainifyWord <$>)
+plainifyWords :: Words -> TL.Text
+plainifyWords = TL.concat . (plainifyWord <$>)
termsByChar :: Terms -> Map Char Terms
termsByChar =
foldr (\aliases acc ->
case aliases of
- (Word w:_):_ | not (Text.null w) ->
+ (Word w:_):_ | not (TL.null w) ->
Map.insertWith (<>)
- (Char.toUpper $ Text.index w 0)
+ (Char.toUpper $ TL.index w 0)
[aliases] acc
_ -> acc
) Map.empty
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
-import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..), Trees)
import Text.Show (Show)
+import qualified Data.Text.Lazy as TL
import Language.XML
, editor :: Maybe Entity
, date :: Maybe Date
, version :: MayText
- , keywords :: [Text]
+ , keywords :: [TL.Text]
, links :: [Link]
, series :: [Serie]
, includes :: [Include]
}
-- * Type 'Body'
-type Body = Trees BodyKey BodyValue
-
--- ** Type 'BodyKey'
-data BodyKey
- = Section { pos :: Pos
- , attrs :: CommonAttrs
- , title :: Title
- , aliases :: [Alias]
- }
- deriving (Eq,Show)
-
--- ** Type 'BodyValue'
-data BodyValue
- = ToC { pos :: Pos
- , attrs :: CommonAttrs
- , depth :: Maybe Nat
+type Body = Trees BodyNode
+
+-- ** Type 'BodyNode'
+data BodyNode
+ = Section { pos :: Pos
+ , attrs :: CommonAttrs
+ , title :: Title
+ , aliases :: [Alias]
+ }
+ | ToC { pos :: Pos
+ , attrs :: CommonAttrs
+ , depth :: Maybe Nat
}
- | ToF { pos :: Pos
- , attrs :: CommonAttrs
- , types :: [Text]
+ | ToF { pos :: Pos
+ , attrs :: CommonAttrs
+ , types :: [TL.Text]
}
- | Figure { pos :: Pos
- , attrs :: CommonAttrs
- , type_ :: Text
- , title :: Maybe Title
- , blocks :: Blocks
+ | Figure { pos :: Pos
+ , attrs :: CommonAttrs
+ , type_ :: TL.Text
+ , mayTitle :: Maybe Title
+ , blocks :: Blocks
}
- | Index { pos :: Pos
- , attrs :: CommonAttrs
- , terms :: Terms
+ | Index { pos :: Pos
+ , attrs :: CommonAttrs
+ , terms :: Terms
}
- | References { pos :: Pos
- , attrs :: CommonAttrs
- , refs :: [Reference]
+ | References { pos :: Pos
+ , attrs :: CommonAttrs
+ , refs :: [Reference]
}
| Block Block
deriving (Eq,Show)
type PosPath = Seq (XmlName,Rank)
-- ** Type 'Word'
-type Word = Text
+type Word = TL.Text
-- *** Type 'Words'
type Words = [WordOrSpace]
-- * Type 'Block'
data Block
- = Para { pos :: Pos
- , attrs :: CommonAttrs
- , para :: Para
+ = Para { pos :: Pos
+ , attrs :: CommonAttrs
+ , para :: Para
}
- | OL { pos :: Pos
- , attrs :: CommonAttrs
- , items :: [Blocks]
+ | OL { pos :: Pos
+ , attrs :: CommonAttrs
+ , items :: [Blocks]
}
- | UL { pos :: Pos
- , attrs :: CommonAttrs
- , items :: [Blocks]
+ | UL { pos :: Pos
+ , attrs :: CommonAttrs
+ , items :: [Blocks]
}
- | Artwork { pos :: Pos
- , attrs :: CommonAttrs
- , art :: Artwork
+ | Artwork { pos :: Pos
+ , attrs :: CommonAttrs
+ , type_ :: TL.Text
+ , text :: TL.Text
}
- | Comment Text
+ | Quote { pos :: Pos
+ , attrs :: CommonAttrs
+ , type_ :: TL.Text
+ , blocks :: Blocks
+ }
+ | Comment TL.Text
deriving (Eq,Show)
-- * Type 'CommonAttrs'
data CommonAttrs
= CommonAttrs
{ id :: Maybe Ident
- , classes :: [Text]
+ , classes :: [TL.Text]
} deriving (Eq,Show)
-- * Type 'Blocks'
type Blocks = [Block]
--- * Type 'Artwork'
-data Artwork
- = Raw Text
- deriving (Eq,Show)
-
-- * Type 'Para'
type Para = Seq Lines
-- * Type 'Lines'
-type Lines = Tree LineKey LineValue
+type Lines = Tree LineNode
--- ** Type 'LineKey'
-data LineKey
+-- ** Type 'LineNode'
+data LineNode
= B
| Code
| Del
| Iref {anchor :: Maybe Anchor, term :: Words}
| Ref {to :: Ident}
| Rref {anchor :: Maybe Anchor, to :: Ident}
+ | BR
+ | Plain TL.Text
deriving (Eq,Show)
-- ** Type 'Anchor'
, count :: Nat1
} deriving (Eq,Ord,Show)
--- ** Type 'LineValue'
-data LineValue
- = BR
- | Plain Text
- deriving (Eq,Show)
-
-- * Type 'Title'
newtype Title = Title { unTitle :: Para }
deriving (Eq,Show,Semigroup,Monoid,Default)
-- ** Type 'Entity'
data Entity
= Entity
- { name :: Text
- , street :: Text
- , zipcode :: Text
- , city :: Text
- , region :: Text
- , country :: Text
- , email :: Text
- , tel :: Text
- , fax :: Text
+ { name :: TL.Text
+ , street :: TL.Text
+ , zipcode :: TL.Text
+ , city :: TL.Text
+ , region :: TL.Text
+ , country :: TL.Text
+ , email :: TL.Text
+ , tel :: TL.Text
+ , fax :: TL.Text
, url :: Maybe URL
, org :: Maybe Entity
} deriving (Eq,Show)
-- * Type 'Link'
data Link
= Link
- { name :: Text
+ { name :: TL.Text
, href :: URL
- , rel :: Text
+ , rel :: TL.Text
, para :: Para
} deriving (Eq,Show)
instance Default Link where
-- * Type 'Serie'
data Serie
= Serie
- { name :: Text
- , key :: Text
+ { name :: TL.Text
+ , key :: TL.Text
} deriving (Eq,Show)
instance Default Serie where
def = Serie
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
import Data.Semigroup (Semigroup(..))
import Data.Sequence (ViewL(..), (|>))
import Data.String (String)
-import Data.Text (Text)
import Data.Tuple (snd)
import Prelude (Num(..))
import Text.Read (readMaybe)
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
-import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Perm as P
-import Language.TCT hiding (Parser)
+import Language.TCT hiding (Parser, ErrorRead)
import Language.XML
import qualified Language.DTC.Document as DTC
import qualified Language.DTC.Sym as DTC
type State = DTC.Pos
-- * Type 'Parser'
--- type Parser = P.Parsec Error XMLs
-type Parser = S.StateT State (P.Parsec Error XMLs)
+-- type Parser = P.Parsec ErrorRead XMLs
+type Parser = S.StateT State (P.Parsec ErrorRead XMLs)
instance RNC.Sym_Rule Parser where
-- rule n p = P.dbg s p {-(p P.<?> s)-} where s = Text.unpack n
(n,ts) <- P.token check $ Just expected
parserXMLs (p n) ts
where
- expected = TreeN (cell0 "") mempty
- check (TreeN (unCell -> n) ts) = Right (n,ts)
+ expected = Tree (cell0 $ XmlElem "") mempty
+ check (Tree (unCell -> XmlElem n) ts) = Right (n,ts)
check t = Left
( Just $ P.Tokens $ pure t
, Set.singleton $ P.Tokens $ pure expected )
DTC.posPrecedingsSiblings xp
}
where
- expected = TreeN (cell0 n) mempty
- check (TreeN (unCell -> e) ts) | e == n = Right ts
+ expected = Tree (cell0 $ XmlElem n) mempty
+ check (Tree (unCell -> XmlElem e) ts) | e == n = Right ts
check t = Left
( Just $ P.Tokens $ pure t
, Set.singleton $ P.Tokens $ pure expected )
parserXMLs p v
where
expected = Tree0 (cell0 $ XmlAttr n "")
- check (TreeN (unCell -> e) ts) | e == n = Right ts
+ check (Tree (unCell -> XmlElem e) ts) | e == n = Right ts
check (Tree0 (Cell bp ep (XmlAttr k v))) | k == n =
Right $ Seq.singleton $ Tree0 $ Cell bp ep $ XmlText v
check t = Left
( Just $ P.Tokens $ pure t
, Set.singleton $ P.Tokens $ pure expected )
int = RNC.rule "int" $ RNC.text >>= \t ->
- case readMaybe (Text.unpack t) of
+ case readMaybe (TL.unpack t) of
Just i -> return i
Nothing -> P.fancyFailure $
- Set.singleton $ P.ErrorCustom $ Error_Not_Int t
+ Set.singleton $ P.ErrorCustom $ ErrorRead_Not_Int t
nat = RNC.rule "nat" $ RNC.int >>= \i ->
if i >= 0
then return $ Nat i
else P.fancyFailure $ Set.singleton $
- P.ErrorCustom $ Error_Not_Nat i
+ P.ErrorCustom $ ErrorRead_Not_Nat i
nat1 = RNC.rule "nat1" $ RNC.int >>= \i ->
if i > 0
then return $ Nat1 i
else P.fancyFailure $ Set.singleton $
- P.ErrorCustom $ Error_Not_Nat1 i
+ P.ErrorCustom $ ErrorRead_Not_Nat1 i
(<|>) = (P.<|>)
many = P.many
some = P.some
readDTC ::
DTC.Sym_DTC Parser =>
XMLs ->
- Either (P.ParseError (P.Token XMLs) Error) DTC.Document
+ Either (P.ParseError (P.Token XMLs) ErrorRead) DTC.Document
readDTC = parseXMLs def (P.initialPos "") DTC.document
parseXMLs ::
DTC.Sym_DTC Parser =>
State ->
P.SourcePos -> Parser a -> XMLs ->
- Either (P.ParseError (P.Token XMLs) Error) a
+ Either (P.ParseError (P.Token XMLs) ErrorRead) a
parseXMLs st pos p i =
snd $
P.runParser' ((`S.evalStateT` st) $ p <* RNC.none)
{ P.stateInput = i
, P.statePos = pure $
case Seq.viewl i of
- Tree0 c :< _ -> sourcePosCell c
- TreeN c _ :< _ -> sourcePosCell c
+ Tree c _ :< _ -> sourcePosCell c
_ -> pos
, P.stateTabWidth = P.pos1
, P.stateTokensProcessed = 0
P.positionAt1 (Proxy::Proxy XMLs) pos t
sourcePosCell :: Cell a -> P.SourcePos
-sourcePosCell c =
+sourcePosCell (cell_begin -> bp) =
P.SourcePos ""
- (P.mkPos $ lineCell c)
- (P.mkPos $ columnCell c)
+ (P.mkPos $ pos_line bp)
+ (P.mkPos $ pos_column bp)
sourcePos :: Pos -> Maybe P.SourcePos
sourcePos (Pos l c) | l>0 && c>0 = Just $ P.SourcePos "" (P.mkPos l) (P.mkPos c)
Tree0 (unCell -> XmlComment{}) :< ts -> P.take1_ ts
t:<ts -> Just (t,ts)
EmptyL -> Nothing
- positionAt1 _s pos t =
- fromMaybe pos $ sourcePos $
- case t of
- TreeN c _ -> posCell c
- Tree0 c -> posCell c
+ positionAt1 _s pos =
+ fromMaybe pos . sourcePos .
+ cell_begin . unTree
positionAtN s pos ts =
case Seq.viewl ts of
t :< _ -> P.positionAt1 s pos t
_ -> pos
- advance1 _s _indent pos t =
+ advance1 _s _indent pos =
-- WARNING: the end of a 'Cell' is not necessarily
-- the beginning of the next 'Cell'.
- fromMaybe pos $ sourcePos $
- case t of
- TreeN c _ -> posEndCell c
- Tree0 c -> posEndCell c
+ fromMaybe pos . sourcePos .
+ cell_end . unTree
advanceN s = foldl' . P.advance1 s
takeN_ n s
| n <= 0 = Just (mempty, s)
showTokens toks = List.intercalate ", " $ toList $ showTree <$> toks
where
showTree :: XML -> String
- showTree = \case
- Tree0 c -> showCell c showXmlLeaf
- TreeN c _ts -> showCell c showXmlName
+ showTree (Tree a _ts) =
+ showCell a $ \case
+ XmlElem n -> "<"<>show n<>">"
+ XmlAttr n _v -> show n<>"="
+ XmlText _t -> "text"
+ XmlComment _c -> "comment"
showCell (Cell (Pos 0 0) (Pos 0 0) a) f = f a
showCell (Cell bp ep a) f = f a<>" at "<>show bp<>"-"<>show ep
-
- showXmlLeaf = \case
- XmlAttr n _v -> show n<>"="
- XmlText _t -> "text"
- XmlComment _c -> "comment"
- showXmlName n = "<"<>show n<>">"
--- ** Type 'Error'
-data Error
- = Error_EndOfInput
- | Error_Not_Int Text
- | Error_Not_Nat Int
- | Error_Not_Nat1 Int
- -- | Error_Unexpected P.sourcePos XML
+-- ** Type 'ErrorRead'
+data ErrorRead
+ = ErrorRead_EndOfInput
+ | ErrorRead_Not_Int TL.Text
+ | ErrorRead_Not_Nat Int
+ | ErrorRead_Not_Nat1 Int
+ -- | ErrorRead_Unexpected P.sourcePos XML
deriving (Eq,Ord,Show)
-instance P.ShowErrorComponent Error where
+instance P.ShowErrorComponent ErrorRead where
showErrorComponent = show
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE StandaloneDeriving #-}
module Language.DTC.Sym where
import Control.Applicative (Applicative(..), (<$>), (<$))
import Data.Foldable (Foldable(..), concat)
import Data.Function (($), (.), flip)
import Data.Maybe (Maybe(..), maybe)
-import Data.Text (Text)
-import Data.TreeSeq.Strict (Tree(..))
+import Data.TreeSeq.Strict (Tree(..), tree0)
import qualified Data.Sequence as Seq
-import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
import Language.XML
import Language.RNC.Sym as RNC
head :: repr DTC.Head
about :: repr DTC.About
- keyword :: repr Text
+ keyword :: repr TL.Text
version :: repr MayText
author :: repr DTC.Entity
editor :: repr DTC.Entity
alias :: repr DTC.Alias
body :: repr DTC.Body
- bodyValue :: repr DTC.BodyValue
- toc :: repr DTC.BodyValue
- tof :: repr DTC.BodyValue
- index :: repr DTC.BodyValue
- figure :: repr DTC.BodyValue
- references :: repr DTC.BodyValue
+ bodyValue :: repr DTC.BodyNode
+ toc :: repr DTC.BodyNode
+ tof :: repr DTC.BodyNode
+ index :: repr DTC.BodyNode
+ figure :: repr DTC.BodyNode
+ references :: repr DTC.BodyNode
reference :: repr DTC.Reference
include :: repr DTC.Include
block :: repr DTC.Block
para :: repr DTC.Para
- lines :: repr (Tree DTC.LineKey DTC.LineValue)
+ lines :: repr DTC.Lines
commonAttrs :: repr DTC.CommonAttrs
ident :: repr Ident
title :: repr DTC.Title
- name :: repr Text
+ name :: repr TL.Text
url :: repr URL
path :: repr Path
to :: repr Ident
interleaved $
DTC.CommonAttrs
<$?> (def, Just <$> id)
- <|?> (def, rule "class" $ attribute "class" $ Text.words <$> text)
+ <|?> (def, rule "class" $ attribute "class" $ TL.words <$> text)
document = rule "document" $
DTC.Document
(Seq.fromList <$>) $
many $
choice
- [ element "section" $ TreeN <$> section <*> body
- , Tree0 <$> bodyValue
+ [ element "section" $ Tree <$> section <*> body
+ , tree0 <$> bodyValue
]
where
section =
<$> position
<*> commonAttrs
<*> many (element "li" $ many block)
+ , element "artwork" $
+ DTC.Artwork
+ <$> position
+ <*> commonAttrs
+ <*> attribute "type" text
+ <*> text
+ , element "quote" $
+ DTC.Quote
+ <$> position
+ <*> commonAttrs
+ <*> attribute "type" text
+ <*> many block
{-
, anyElem $ \n@XmlName{..} ->
case xmlNameSpace of
element "para" $
(concat <$>) $
many $
- (wordify <$>) . Text.lines <$> text)
+ (wordify <$>) . TL.lines <$> text)
figure =
rule "figure" $
element "figure" $
lines =
rule "lines" $
choice
- [ element "b" $ TreeN DTC.B <$> para
- , element "code" $ TreeN DTC.Code <$> para
- , element "del" $ TreeN DTC.Del <$> para
- , element "i" $ TreeN DTC.I <$> para
- , element "note" $ TreeN (DTC.Note Nothing) <$> para
- , element "q" $ TreeN DTC.Q <$> para
- , element "sc" $ TreeN DTC.SC <$> para
- , element "sub" $ TreeN DTC.Sub <$> para
- , element "sup" $ TreeN DTC.Sup <$> para
- , element "u" $ TreeN DTC.U <$> para
- , element "eref" $ TreeN . DTC.Eref <$> attribute "to" url <*> para
- , element "iref" $ TreeN . DTC.Iref Nothing . wordify <$> attribute "to" text <*> para
- , element "ref" $ TreeN . DTC.Ref <$> to <*> para
- , element "rref" $ TreeN . DTC.Rref Nothing <$> to <*> para
- , element "br" $ Tree0 DTC.BR <$ none
- , Tree0 . DTC.Plain <$> text
+ [ element "b" $ Tree DTC.B <$> para
+ , element "code" $ Tree DTC.Code <$> para
+ , element "del" $ Tree DTC.Del <$> para
+ , element "i" $ Tree DTC.I <$> para
+ , element "note" $ Tree (DTC.Note Nothing) <$> para
+ , element "q" $ Tree DTC.Q <$> para
+ , element "sc" $ Tree DTC.SC <$> para
+ , element "sub" $ Tree DTC.Sub <$> para
+ , element "sup" $ Tree DTC.Sup <$> para
+ , element "u" $ Tree DTC.U <$> para
+ , element "eref" $ Tree . DTC.Eref <$> attribute "to" url <*> para
+ , element "iref" $ Tree . DTC.Iref Nothing . wordify <$> attribute "to" text <*> para
+ , element "ref" $ Tree . DTC.Ref <$> to <*> para
+ , element "rref" $ Tree . DTC.Rref Nothing <$> to <*> para
+ , element "br" $ tree0 DTC.BR <$ none
+ , tree0 . DTC.Plain <$> text
]
keyword = rule "keyword" $
element "keyword" text
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.DTC.Write.HTML5 where
--- import Control.Monad.Trans.Class (MonadTrans(..))
--- import Data.Functor.Identity (Identity(..))
--- import Data.Sequence (Seq)
--- import Data.Set (Set)
--- import Data.Traversable (Traversable(..))
--- import qualified Data.Sequence as Seq
--- import qualified Data.TreeSeq.Strict as Tree
import Control.Applicative (Applicative(..))
import Control.Category
import Control.Monad
import Data.Monoid (Monoid(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (String)
+import Data.String (String, IsString(..))
import Data.Text (Text)
-import Data.TreeSeq.Strict (Tree(..), Trees)
+import Data.TreeSeq.Strict (Tree(..), tree0)
import Data.Tuple (snd)
import System.FilePath (FilePath)
import Text.Blaze ((!))
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import qualified Data.TreeMap.Strict as TreeMap
-import qualified Data.TreeSeq.Strict as Tree
import qualified Data.TreeSeq.Strict.Zipper as Tree
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import qualified Text.Blaze.Internal as H
import Text.Blaze.Utils
-import Data.Locale hiding (localize, Index)
+import Data.Locale hiding (Index)
import qualified Data.Locale as Locale
import Language.DTC.Write.XML ()
-- * Type 'Html5'
type Html5 = StateMarkup State ()
+instance IsString Html5 where
+ fromString = html5ify
-- * Type 'State'
data State
, state_scripts :: Map FilePath Script
, state_indexs :: Map DTC.Pos (DTC.Terms, Anchor.Irefs)
, state_rrefs :: Anchor.Rrefs
- , state_figures :: Map Text (Map DTC.Pos (Maybe DTC.Title))
+ , state_figures :: Map TL.Text (Map DTC.Pos (Maybe DTC.Title))
, state_references :: Map DTC.Ident DTC.About
, state_notes :: Anchor.Notes
, state_plainify :: Plain.State
data Keys
= Keys
{ keys_index :: Map DTC.Pos DTC.Terms
- , keys_figure :: Map Text (Map DTC.Pos (Maybe DTC.Title))
+ , keys_figure :: Map TL.Text (Map DTC.Pos (Maybe DTC.Title))
, keys_reference :: Map DTC.Ident DTC.About
} deriving (Show)
instance Default Keys where
-- ** Class 'KeysOf'
class KeysOf a where
keys :: a -> S.State Keys ()
-instance KeysOf (Trees DTC.BodyKey DTC.BodyValue) where
+instance KeysOf DTC.Body where
keys = mapM_ keys
-instance KeysOf (Tree DTC.BodyKey DTC.BodyValue) where
- keys = \case
- TreeN k ts ->
- case k of
+instance KeysOf (Tree DTC.BodyNode) where
+ keys (Tree n ts) =
+ case n of
DTC.Section{..} ->
keys ts
- Tree0 v ->
- case v of
DTC.Index{..} ->
S.modify $ \s -> s{keys_index=
Map.insert pos terms $ keys_index s}
DTC.Figure{..} ->
S.modify $ \s -> s{keys_figure=
Map.insertWith (<>)
- type_ (Map.singleton pos title) $
+ type_ (Map.singleton pos mayTitle) $
keys_figure s}
DTC.References{..} ->
S.modify $ \s -> s{keys_reference=
-- * Class 'Html5ify'
class Html5ify a where
html5ify :: a -> Html5
+instance Html5ify H.Markup where
+ html5ify = Compose . return
instance Html5ify Char where
html5ify = html5ify . H.toMarkup
instance Html5ify Text where
html5ify = html5ify . H.toMarkup
instance Html5ify String where
html5ify = html5ify . H.toMarkup
-instance Html5ify H.Markup where
- html5ify = Compose . return
instance Html5ify DTC.Title where
html5ify (DTC.Title t) = html5ify t
instance Html5ify DTC.Para where
instance Html5ify DTC.Nat1 where
html5ify (DTC.Nat1 n) = html5ify n
-html5Document ::
+document ::
Localize ls Plain Plain.L10n =>
Locales ls =>
LocaleIn ls -> DTC.Document -> Html
-html5Document locale DTC.Document{..} = do
+document locale DTC.Document{..} = do
let Keys{..} = keys body `S.execState` def
let (body',state_rrefs,state_notes,state_indexs) =
let irefs = foldMap Anchor.irefsOfTerms keys_index in
H.link ! HA.rel (attrify rel)
! HA.href (attrify href)
H.meta ! HA.name "generator"
- ! HA.content "tct"
+ ! HA.content "https://hackage.haskell.org/package/hdoc"
let chapters =
(`mapMaybe` toList body) $ \case
- TreeN k@DTC.Section{} _ -> Just k
+ Tree k@DTC.Section{} _ -> Just k
_ -> Nothing
- forM_ chapters $ \DTC.Section{..} ->
+ forM_ chapters $ \case
+ DTC.Section{..} ->
H.link ! HA.rel "Chapter"
! HA.title (attrify $ plainify title)
! HA.href ("#"<>attrify pos)
+ _ -> mempty
H.link ! HA.rel "stylesheet"
! HA.type_ "text/css"
! HA.href "style/dtc-html5.css"
-- * Type 'BodyCursor'
-- | Cursor to navigate within a 'DTC.Body' according to many axis (like in XSLT).
-type BodyCursor = Tree.Zipper DTC.BodyKey DTC.BodyValue
+type BodyCursor = Tree.Zipper DTC.BodyNode
instance Html5ify DTC.Body where
html5ify body =
forM_ (Tree.zippers body) $ \z ->
instance Html5ify BodyCursor
where html5ify z =
case Tree.current z of
- TreeN k _ts ->
+ Tree k _ts ->
case k of
DTC.Section{..} ->
H.section ! HA.class_ "section"
"↑"
H.td $$
html5ify para
- Tree0 v ->
- case v of
DTC.Block b -> html5ify b
DTC.ToC{..} -> do
H.nav ! HA.class_ "toc"
H.table ! HA.class_ "figure-caption" $$
H.tbody $$
H.tr $$ do
- H.td ! HA.class_ "figure-number" $$ do
- H.a ! HA.href ("#"<>attrify pos) $$ do
- html5ify type_
- html5ify $ DTC.posAncestors pos
- forM_ title $ \ti ->
+ if TL.null type_
+ then H.a ! HA.href ("#"<>attrify pos) $$ mempty
+ else
+ H.td ! HA.class_ "figure-number" $$ do
+ H.a ! HA.href ("#"<>attrify pos) $$ do
+ html5ify type_
+ html5ify $ DTC.posAncestors pos
+ forM_ mayTitle $ \title ->
H.td ! HA.class_ "figure-title" $$ do
- html5ify $ Plain.L10n_Colon
- html5ify ti
+ unless (TL.null type_) $
+ html5ify $ Plain.L10n_Colon
+ html5ify title
H.div ! HA.class_ "figure-content" $$ do
html5ify blocks
DTC.Index{pos} -> do
html5ify = html5ify . Anchor.plainifyWords
cleanPara :: DTC.Para -> DTC.Para
-cleanPara p =
- p >>= (`Tree.bindTrees` \case
- TreeN DTC.Iref{} ls -> ls
- TreeN DTC.Note{} _ -> mempty
- h -> pure h)
+cleanPara ps =
+ ps >>= \case
+ Tree DTC.Iref{} ls -> cleanPara ls
+ Tree DTC.Note{} _ -> mempty
+ Tree n ts -> pure $ Tree n $ cleanPara ts
html5ifyToC :: Maybe DTC.Nat -> BodyCursor -> Html5
html5ifyToC depth z =
case Tree.current z of
- TreeN DTC.Section{..} _ts -> do
+ Tree DTC.Section{..} _ts -> do
H.li $$ do
H.table ! HA.class_ "toc-entry" $$
H.tbody $$
(`Tree.runAxis` z) $
Tree.axis_child
`Tree.axis_filter_current` \case
- TreeN DTC.Section{} _ -> True
+ Tree DTC.Section{} _ -> True
_ -> False
-html5ifyToF :: [Text] -> Html5
+html5ifyToF :: [TL.Text] -> Html5
html5ifyToF types = do
figsByType <- liftStateMarkup $ S.gets state_figures
let figs =
! HA.id (attrify pos) $$ do
forM_ items $ \item ->
H.li $$ html5ify item
+ DTC.Artwork{..} ->
+ html5CommonAttrs attrs $
+ H.pre ! HA.class_ ("artwork " <> attrify ("artwork-"<>type_))
+ ! HA.id (attrify pos) $$ do
+ html5ify text
+ DTC.Quote{..} ->
+ html5CommonAttrs attrs $
+ H.div ! HA.class_ ("quote " <> attrify ("quote-"<>type_))
+ ! HA.id (attrify pos) $$ do
+ html5ify blocks
DTC.Comment t ->
- html5ify $ H.Comment (H.Text t) ()
+ html5ify $ H.Comment (H.String $ TL.unpack t) ()
instance Html5ify DTC.Lines where
- html5ify = \case
- Tree0 v ->
- case v of
+ html5ify (Tree n ls) =
+ case n of
DTC.BR -> html5ify H.br
DTC.Plain t -> html5ify t
- TreeN k ls ->
- case k of
DTC.B -> H.strong $$ html5ify ls
DTC.Code -> H.code $$ html5ify ls
DTC.Del -> H.del $$ html5ify ls
return depth
H.span ! HA.class_ "q" $$ do
html5ify $ Plain.L10n_QuoteOpen depth
- html5ify $ TreeN DTC.I ls
+ html5ify $ Tree DTC.I ls
html5ify $ Plain.L10n_QuoteClose depth
liftStateMarkup $
S.modify $ \s ->
html5ify to
"]"
Just DTC.About{..} -> do
- when (not $ null ls) $
+ unless (null ls) $
forM_ (List.take 1 titles) $ \(DTC.Title title) -> do
- html5ify $ TreeN DTC.Q $
+ html5ify $ Tree DTC.Q $
case url of
Nothing -> title
- Just u -> pure $ TreeN (DTC.Eref u) title
+ Just u -> pure $ Tree (DTC.Eref u) title
" "::Html5
"["::Html5
H.a ! HA.class_ "rref"
html5Titles :: [DTC.Title] -> [Html5]
html5Titles ts | null ts = []
html5Titles ts = [html5Title $ fold $ List.intersperse t $ toList ts]
- where t = DTC.Title $ Seq.singleton $ Tree0 $ DTC.Plain " — "
+ where t = DTC.Title $ Seq.singleton $ tree0 $ DTC.Plain " — "
html5Title (DTC.Title title) =
- html5ify $ TreeN DTC.Q $
+ html5ify $ Tree DTC.Q $
case url of
Nothing -> title
- Just u -> pure $ TreeN (DTC.Eref u) title
+ Just u -> pure $ Tree (DTC.Eref u) title
html5SerieHref href DTC.Serie{..} = do
sp <- liftStateMarkup $ S.gets state_plainify
html5ify $
- TreeN DTC.Eref{href} $
+ Tree DTC.Eref{href} $
Seq.fromList
- [ Tree0 $ DTC.Plain $ name
- , Tree0 $ DTC.Plain $ TL.toStrict $ Plain.text sp Plain.L10n_Colon
- , Tree0 $ DTC.Plain key
+ [ tree0 $ DTC.Plain $ name
+ , tree0 $ DTC.Plain $ Plain.text sp Plain.L10n_Colon
+ , tree0 $ DTC.Plain key
]
- html5Serie s@DTC.Serie{name="RFC", key} | Text.all Char.isDigit key =
+ html5Serie s@DTC.Serie{name="RFC", key} | TL.all Char.isDigit key =
html5SerieHref (DTC.URL $ "https://tools.ietf.org/html/rfc"<>key) s
html5Serie s@DTC.Serie{name="DOI", key} =
html5SerieHref (DTC.URL $ "https://dx.doi.org/"<>key) s
html5Entity DTC.Entity{url=mu, ..} = do
html5ify @DTC.Lines $
case () of
- _ | not (Text.null email) ->
- TreeN (DTC.Eref $ DTC.URL $ "mailto:"<>email) $
- pure $ Tree0 $ DTC.Plain name
+ _ | not (TL.null email) ->
+ Tree (DTC.Eref $ DTC.URL $ "mailto:"<>email) $
+ pure $ tree0 $ DTC.Plain name
_ | Just u <- mu ->
- TreeN (DTC.Eref u) $
- pure $ Tree0 $ DTC.Plain name
- _ -> Tree0 $ DTC.Plain name
+ Tree (DTC.Eref u) $
+ pure $ tree0 $ DTC.Plain name
+ _ -> tree0 $ DTC.Plain name
forM_ org $ \o -> do
" ("::Html5
html5Entity o
html5ify DTC.Reference{id=id_, ..} =
H.tr $$ do
H.td ! HA.class_ "reference-key" $$
- html5ify @DTC.Lines $ TreeN DTC.Rref{anchor=Nothing, to=id_} Seq.empty
+ html5ify @DTC.Lines $ Tree DTC.Rref{anchor=Nothing, to=id_} Seq.empty
H.td ! HA.class_ "reference-content" $$ do
html5ify about
rrefs <- liftStateMarkup $ S.gets state_rrefs
addClass =
case classes of
[] -> id
- _ -> H.AddCustomAttribute "class" (H.Text $ Text.unwords classes)
+ _ -> H.AddCustomAttribute "class" $
+ H.String $ TL.unpack $ TL.unwords classes
addId = maybe id (\(DTC.Ident i) ->
- H.AddCustomAttribute "id" (H.Text i)) id_
+ H.AddCustomAttribute "id" (H.String $ TL.unpack i)) id_
html5SectionNumber :: DTC.PosPath -> Html5
html5SectionNumber = go mempty
-{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.DTC.Write.Plain where
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (String)
import Data.Text (Text)
import Data.TreeSeq.Strict (Tree(..))
import Data.Tuple (fst, snd)
-import Data.String (IsString(..))
+import Data.String (String, IsString(..))
import Prelude (mod)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State as S
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
-import Data.Locale hiding (localize, Index)
+import Data.Locale hiding (Index)
import Language.DTC.Write.XML ()
import qualified Language.DTC.Document as DTC
instance Plainify DTC.Para where
plainify = foldMap plainify
instance Plainify DTC.Lines where
- plainify = \case
- Tree0 v ->
- case v of
- DTC.BR -> "\n"
- DTC.Plain p -> plainify p
- TreeN k ls ->
- case k of
+ plainify (Tree n ls) =
+ case n of
+ DTC.BR -> "\n"
+ DTC.Plain p -> plainify p
DTC.B -> "*"<>plainify ls<>"*"
DTC.Code -> "`"<>plainify ls<>"`"
DTC.Del -> "-"<>plainify ls<>"-"
DTC.Note{..} -> ""
DTC.Q ->
let depth = DTC.Nat 0 in
- plainify (L10n_QuoteOpen{..}) <>
+ plainify L10n_QuoteOpen{..} <>
plainify ls <>
- plainify (L10n_QuoteClose{..})
+ plainify L10n_QuoteClose{..}
DTC.SC -> plainify ls
DTC.Sub -> plainify ls
DTC.Sup -> plainify ls
import Data.Maybe (Maybe(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
-import Data.Text (Text)
import Text.Blaze ((!))
import Text.Blaze.Utils
import Text.Blaze.XML (XML)
import qualified Data.Char as Char
import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
+import qualified Data.Text.Lazy as TL
import qualified Text.Blaze as B
import qualified Text.Blaze.DTC as XML
import qualified Text.Blaze.DTC.Attributes as XA
import Language.DTC.Anchor (plainifyWords)
import qualified Language.DTC.Document as DTC
-xmlText :: Text -> XML
-xmlText = B.toMarkup
-
-xmlDocument :: Locales ls => LocaleIn ls -> DTC.Document -> XML
-xmlDocument loc DTC.Document{..} = do
+document :: Locales ls => LocaleIn ls -> DTC.Document -> XML
+document loc DTC.Document{..} = do
let lang = Text.takeWhile Char.isAlphaNum $ textLocales Map.! loc
XML.xmlModel "./schema/dtc.rnc"
XML.xmlStylesheet $ "./xsl/document.html5."<>lang<>".xsl"
xmlHead head
xmlBody body
+xmlText :: TL.Text -> XML
+xmlText = B.toMarkup
+
xmlHead :: DTC.Head -> XML
xmlHead DTC.Head{..} =
XML.about $ xmlAbout about
xmlBody :: DTC.Body -> XML
-xmlBody = mapM_ $ \case
- TreeN k ts -> xmlBodyKey k $ xmlBody ts
- Tree0 v -> xmlBodyValue v
-
-xmlBodyKey :: DTC.BodyKey -> XML -> XML
-xmlBodyKey k body = case k of
+xmlBody = mapM_ $ \(Tree n ts) ->
+ case n of
DTC.Section{..} ->
xmlCommonAttrs attrs $
XML.section $ do
xmlTitle title
forM_ aliases xmlAlias
- body
-
-xmlBodyValue :: DTC.BodyValue -> XML
-xmlBodyValue = \case
+ xmlBody ts
DTC.ToC{..} ->
xmlCommonAttrs attrs $
XML.toc
forM_ terms $ \aliases ->
XML.li $
xmlText $
- Text.unlines $
+ TL.unlines $
plainifyWords <$> aliases
DTC.Figure{..} ->
xmlCommonAttrs attrs $
XML.figure
! XA.type_ (attrify type_) $ do
- forM_ title xmlTitle
+ forM_ mayTitle xmlTitle
xmlBlocks blocks
DTC.References{..} ->
xmlCommonAttrs attrs $
XML.include True
! XA.href (attrify href)
-xmlKeyword :: Text -> XML
+xmlKeyword :: TL.Text -> XML
xmlKeyword = XML.keyword . xmlText
xmlVersion :: MayText -> XML
xmlCommonAttrs DTC.CommonAttrs{id=ident, ..} =
(case ident of
Nothing -> \m -> m
- Just (DTC.Ident i) -> B.AddCustomAttribute "id" (B.Text i)) .
+ Just (DTC.Ident i) ->
+ B.AddCustomAttribute "id" $
+ B.String $ TL.unpack i) .
case classes of
[] -> \m -> m
- _ -> B.AddCustomAttribute "class" (B.Text $ Text.unwords classes)
+ _ ->
+ B.AddCustomAttribute "class" $
+ B.String $ TL.unpack $ TL.unwords classes
xmlBlock :: DTC.Block -> XML
xmlBlock = \case
xmlCommonAttrs attrs $
XML.ul $ forM_ items $ XML.li . xmlBlocks
DTC.Comment c ->
- XML.comment c
+ XML.comment $ TL.toStrict c
DTC.Artwork{..} ->
xmlCommonAttrs attrs $
- XML.artwork mempty
+ XML.artwork
+ ! XA.type_ (attrify type_) $ do
+ xmlText text
+ DTC.Quote{..} ->
+ xmlCommonAttrs attrs $
+ XML.quote
+ ! XA.type_ (attrify type_) $ do
+ xmlBlocks blocks
xmlPara :: DTC.Para -> XML
xmlPara = (`forM_` xmlLine)
-xmlLine :: Tree DTC.LineKey DTC.LineValue -> XML
-xmlLine = \case
- Tree0 v ->
- case v of
+xmlLine :: DTC.Lines -> XML
+xmlLine (Tree n ls) =
+ case n of
DTC.Plain p -> B.toMarkup p
DTC.BR -> XML.br
- TreeN k ls ->
- case k of
DTC.B -> XML.b $ xmlPara ls
DTC.Code -> XML.code $ xmlPara ls
DTC.Del -> XML.del $ xmlPara ls
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilyDependencies #-}
module Language.RNC.Sym where
import Data.Maybe (Maybe(..))
import Data.Text (Text)
import Text.Show (Show)
+import qualified Data.Text.Lazy as TL
import Language.XML
) => Sym_RNC repr where
element :: XmlName -> repr a -> repr a
attribute :: XmlName -> repr a -> repr a
- comment :: repr Text
+ comment :: repr TL.Text
try :: repr a -> repr a
none :: repr ()
anyElem :: Show a => (XmlName -> repr a) -> repr a
any :: repr ()
- text :: repr Text
+ text :: repr TL.Text
int :: repr Int
nat :: repr Nat
nat1 :: repr Nat1
| otherwise = Just $ Nat1 $ pred n
-- * Type 'Ident'
-newtype Ident = Ident { unIdent :: Text }
+newtype Ident = Ident { unIdent :: TL.Text }
deriving (Eq,Ord,Show,Default,IsString)
-instance Default Text where
- def = ""
-- * Type 'URL'
-newtype URL = URL { unURL :: Text }
+newtype URL = URL { unURL :: TL.Text }
deriving (Eq,Ord,Show,Default)
instance Semigroup URL where
_x <> y = y
-- * Type 'Path'
-newtype Path = Path Text
+newtype Path = Path TL.Text
deriving (Eq,Show,Default)
-- * Type 'MayText'
newtype MayText
- = MayText { unMayText :: Text }
+ = MayText { unMayText :: TL.Text }
deriving (Eq,Show,Default)
instance Semigroup MayText where
MayText "" <> y = y
whenMayText :: Applicative m => MayText -> (MayText -> m ()) -> m ()
whenMayText (MayText "") _f = pure ()
whenMayText t f = f t
+
+instance Default Text where
+ def = ""
+instance Default TL.Text where
+ def = ""
instance MayAttr Text where
mayAttr _ "" = Nothing
mayAttr a t = Just (a $ fromString $ Text.unpack t)
+instance MayAttr TL.Text where
+ mayAttr _ "" = Nothing
+ mayAttr a t = Just (a $ fromString $ TL.unpack t)
instance MayAttr Int where
mayAttr a t = Just (a $ fromString $ show t)
instance MayAttr [Char] where