Sync DTC with new TCT parsing.
authorJulien Moutinho <julm+hdoc@autogeree.net>
Mon, 12 Feb 2018 22:45:44 +0000 (23:45 +0100)
committerJulien Moutinho <julm+hdoc@autogeree.net>
Mon, 12 Feb 2018 22:45:44 +0000 (23:45 +0100)
Data/TreeSeq/Strict/Zipper.hs
Language/DTC/Anchor.hs
Language/DTC/Document.hs
Language/DTC/Read/TCT.hs
Language/DTC/Sym.hs
Language/DTC/Write/HTML5.hs
Language/DTC/Write/Plain.hs
Language/DTC/Write/XML.hs
Language/RNC/Sym.hs
Language/XML.hs
Text/Blaze/Utils.hs

index e947e0dfbf689620fb892c4d23047b8e6e221365..fd595f4a06e45bcb89d07e92319e53d188453f35 100644 (file)
@@ -24,111 +24,110 @@ import qualified Data.Sequence as Seq
 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 a
+data Cursor a
  =   Cursor
- {   cursor_preceding_siblings :: Trees a
- ,   cursor_self               :: Tree  a
- ,   cursor_following_siblings :: Trees 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
@@ -136,55 +135,51 @@ axis_at axis i = Kleisli $ \z ->
 infixl 5 `axis_at`
 
 -- ** Axis @self@
-axis_self :: Applicative f => AxisAlt f a
+axis_self :: Applicative f => AxisAlt f a
 axis_self = Kleisli pure
 
 -- ** Axis @child@
-axis_child :: Axis 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 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 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 a
+axis_ancestor :: Axis a
 axis_ancestor = axis_repeat_without_self axis_parent
 
-axis_ancestor_or_self :: Axis a
+axis_ancestor_or_self :: Axis a
 axis_ancestor_or_self = axis_repeat axis_parent
 
-axis_root :: Alternative f => AxisAlt f 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 a
+axis_descendant_or_self :: Axis a
 axis_descendant_or_self =
        Kleisli $ collect_child []
        where
@@ -199,70 +194,66 @@ axis_descendant_or_self =
                         (runAxisAlt axis_following_sibling_nearest z)
                 ) z
 
-axis_descendant_or_self_reverse :: Axis 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 a
+axis_descendant :: Axis a
 axis_descendant = Kleisli $ List.tail . runAxis axis_descendant_or_self
 
 -- ** Axis @preceding@
-axis_preceding_sibling :: Axis 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 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 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 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 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 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 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 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 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
index d2d50214553533efa5bed34767907d6a9d59591d..694f39c7b438890d565969cfde850c8f9dad7bf4 100644 (file)
@@ -19,19 +19,18 @@ import Data.Maybe (Maybe(..), maybe)
 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
 
@@ -41,7 +40,7 @@ type PathWord = TreeMap.Path Word
 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
@@ -82,36 +81,34 @@ instance Default State where
 -- * 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
@@ -133,7 +130,8 @@ instance Anchorify Block where
         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
@@ -147,10 +145,9 @@ instance Anchorify Para where
                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
@@ -167,42 +164,36 @@ instance Anchorify Para where
                                                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
@@ -212,14 +203,14 @@ 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 ->
@@ -251,36 +242,36 @@ indexifyWords section = go mempty
                                                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
index 9752c924b9c830c75404e9e44d8e84c29545ea5a..e439392c899df62074cad14f3109924c0dbd9baf 100644 (file)
@@ -18,9 +18,9 @@ import Data.Monoid (Monoid(..))
 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
 
@@ -55,7 +55,7 @@ data About
  ,   editor   :: Maybe Entity
  ,   date     :: Maybe Date
  ,   version  :: MayText
- ,   keywords :: [Text]
+ ,   keywords :: [TL.Text]
  ,   links    :: [Link]
  ,   series   :: [Serie]
  ,   includes :: [Include]
@@ -88,40 +88,36 @@ instance Semigroup About where
         }
 
 -- * 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)
@@ -142,7 +138,7 @@ instance Default Pos where
 type PosPath = Seq (XmlName,Rank)
 
 -- ** Type 'Word'
-type Word = Text
+type Word = TL.Text
 
 -- *** Type 'Words'
 type Words = [WordOrSpace]
@@ -164,48 +160,49 @@ type Count = Int
 
 -- * 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
@@ -220,6 +217,8 @@ data LineKey
  | Iref {anchor :: Maybe Anchor, term :: Words}
  | Ref  {to :: Ident}
  | Rref {anchor :: Maybe Anchor, to :: Ident}
+ | BR
+ | Plain TL.Text
  deriving (Eq,Show)
 
 -- ** Type 'Anchor'
@@ -229,12 +228,6 @@ data 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)
@@ -242,15 +235,15 @@ newtype Title = Title { unTitle :: Para }
 -- ** 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)
@@ -315,9 +308,9 @@ instance Semigroup Date where
 -- * 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
@@ -341,8 +334,8 @@ instance Default Alias 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
index d947edadcdd138135c3ab2fad0c9ff234a6961a6..dc8db78b4b8fe56927ef23e93e7b0d8678a5f236 100644 (file)
@@ -1,4 +1,3 @@
-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -27,7 +26,6 @@ import Data.Proxy (Proxy(..))
 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)
@@ -37,11 +35,11 @@ import qualified Data.List as List
 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
@@ -51,8 +49,8 @@ import qualified Language.RNC.Sym as RNC
 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
@@ -64,8 +62,8 @@ instance RNC.Sym_RNC Parser where
                (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 )
@@ -105,8 +103,8 @@ instance RNC.Sym_RNC Parser where
                        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 )
@@ -115,7 +113,7 @@ instance RNC.Sym_RNC Parser where
                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
@@ -142,20 +140,20 @@ instance RNC.Sym_RNC Parser where
                 ( 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
@@ -178,14 +176,14 @@ instance DTC.Sym_DTC Parser where
 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)
@@ -193,8 +191,7 @@ parseXMLs st pos p i =
                 { 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
@@ -235,10 +232,10 @@ fixPos = do
                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)
@@ -252,22 +249,18 @@ instance P.Stream XMLs where
                 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 =
+       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)
@@ -281,26 +274,23 @@ instance P.ShowToken XML where
        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
index a37f4651765c94cd67c7117e41463ca70f5d1360..de7c09c024c8159609a0ad87a99f80e3c6c95103 100644 (file)
@@ -1,7 +1,5 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE StandaloneDeriving #-}
 module Language.DTC.Sym where
 
 import Control.Applicative (Applicative(..), (<$>), (<$))
@@ -10,10 +8,9 @@ import Data.Default.Class (Default(..))
 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
@@ -32,7 +29,7 @@ class RNC.Sym_RNC repr => Sym_DTC repr where
        
        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
@@ -43,23 +40,23 @@ class RNC.Sym_RNC repr => Sym_DTC repr where
        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
@@ -70,7 +67,7 @@ class RNC.Sym_RNC repr => Sym_DTC repr where
                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
@@ -84,8 +81,8 @@ class RNC.Sym_RNC repr => Sym_DTC repr where
                (Seq.fromList <$>) $
                many $
                        choice
-                        [ element "section" $ TreeN <$> section <*> body
-                        , Tree0 <$> bodyValue
+                        [ element "section" $ Tree <$> section <*> body
+                        , tree0 <$> bodyValue
                         ]
                where
                section =
@@ -140,6 +137,18 @@ class RNC.Sym_RNC repr => Sym_DTC repr where
                         <$> 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
@@ -177,7 +186,7 @@ class RNC.Sym_RNC repr => Sym_DTC repr where
                                                element "para" $
                                                        (concat <$>) $
                                                        many $
-                                                               (wordify <$>) . Text.lines <$> text)
+                                                               (wordify <$>) . TL.lines <$> text)
        figure =
                rule "figure" $
                element "figure" $
@@ -197,22 +206,22 @@ class RNC.Sym_RNC repr => Sym_DTC repr where
        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
index eb49167f70b8dfc9422ac3655cd402ef00d719e7..1509bbd23f70ba98b596c497fbde3437befec428 100644 (file)
@@ -5,17 +5,9 @@
 {-# 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
@@ -32,9 +24,9 @@ import Data.Maybe (Maybe(..), maybe, mapMaybe, fromJust, maybeToList)
 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 ((!))
@@ -49,14 +41,13 @@ 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.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 ()
@@ -71,6 +62,8 @@ infixl 4 <&>
 
 -- * Type 'Html5'
 type Html5 = StateMarkup State ()
+instance IsString Html5 where
+       fromString = html5ify
 
 -- * Type 'State'
 data State
@@ -79,7 +72,7 @@ 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
@@ -102,7 +95,7 @@ type Script = Text
 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
@@ -111,23 +104,20 @@ 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=
@@ -144,6 +134,8 @@ instance KeysOf (Tree DTC.BodyKey DTC.BodyValue) where
 -- * 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
@@ -152,8 +144,6 @@ instance Html5ify TL.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
@@ -167,11 +157,11 @@ instance Html5ify DTC.Nat 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
@@ -207,15 +197,17 @@ html5Document locale DTC.Document{..} = do
                                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"
@@ -230,7 +222,7 @@ html5Document locale DTC.Document{..} = do
 
 -- * 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 ->
@@ -239,7 +231,7 @@ instance Html5ify DTC.Body where
 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"
@@ -282,8 +274,6 @@ instance Html5ify BodyCursor
                                                                                                "↑"
                                                                                H.td $$
                                                                                        html5ify para
-        Tree0 v ->
-               case v of
                 DTC.Block b -> html5ify b
                 DTC.ToC{..} -> do
                        H.nav ! HA.class_ "toc"
@@ -307,14 +297,18 @@ instance Html5ify BodyCursor
                                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
@@ -364,16 +358,16 @@ instance Html5ify DTC.Words where
        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 $$
@@ -392,10 +386,10 @@ html5ifyToC depth z =
                (`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 =
@@ -436,16 +430,23 @@ instance Html5ify DTC.Block where
                     ! 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
@@ -485,7 +486,7 @@ instance Html5ify DTC.Lines where
                                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 ->
@@ -519,12 +520,12 @@ instance Html5ify DTC.Lines where
                                        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"
@@ -552,22 +553,22 @@ instance Html5ify DTC.About where
                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
@@ -578,13 +579,13 @@ instance Html5ify DTC.About where
                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
@@ -593,7 +594,7 @@ instance Html5ify DTC.Reference where
        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
@@ -636,9 +637,10 @@ html5CommonAttrs DTC.CommonAttrs{id=id_, ..} =
        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
index 5f27d137dbf1f1d37e0d17aa44fa1944d37680e5..bc3f953d637dae271f8a09c107a26f7040f6662a 100644 (file)
@@ -1,11 +1,9 @@
-{-# 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
 
@@ -21,11 +19,10 @@ import Data.Int (Int)
 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
@@ -33,7 +30,7 @@ import qualified Data.List as List
 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
@@ -84,13 +81,10 @@ instance Plainify TL.Text where
 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<>"-"
@@ -98,9 +92,9 @@ instance Plainify DTC.Lines where
                 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
index ae902c7a8c6937b2bd6e9a98f9c1c5e5a2ef63e8..a1729f9f3852a7d2bdf70618359a0270be1787ae 100644 (file)
@@ -9,7 +9,6 @@ import Data.Functor ((<$>))
 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)
@@ -17,6 +16,7 @@ import Data.TreeSeq.Strict (Tree(..))
 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
@@ -27,11 +27,8 @@ import Language.DTC.Document (MayText(..), whenMayText)
 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"
@@ -41,26 +38,22 @@ xmlDocument loc DTC.Document{..} = do
                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
@@ -78,13 +71,13 @@ xmlBodyValue = \case
                                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 $
@@ -107,7 +100,7 @@ xmlInclude DTC.Include{..} =
        XML.include True
         ! XA.href (attrify href)
 
-xmlKeyword :: Text -> XML
+xmlKeyword :: TL.Text -> XML
 xmlKeyword = XML.keyword . xmlText
 
 xmlVersion :: MayText -> XML
@@ -157,10 +150,14 @@ xmlCommonAttrs :: DTC.CommonAttrs -> XML -> 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
@@ -174,22 +171,26 @@ 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
index d584502c71e44352c53821f4bfe60c7bc9c87a37..9672f91e38250745ce82e7c88361980187bc7b87 100644 (file)
@@ -1,7 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilyDependencies #-}
 module Language.RNC.Sym where
 
@@ -13,6 +12,7 @@ import Data.Int (Int)
 import Data.Maybe (Maybe(..))
 import Data.Text (Text)
 import Text.Show (Show)
+import qualified Data.Text.Lazy as TL
 
 import Language.XML
 
@@ -57,12 +57,12 @@ class
  ) => 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
index 6d6d01e0034008c473acf2fa028042d0421404fe..a702865610aa8fb2cf01472b1757acc1a04205bc 100644 (file)
@@ -105,24 +105,22 @@ predNat1 (Nat1 n) | n <= 1    = Nothing
                   | 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
@@ -132,3 +130,8 @@ instance Semigroup MayText where
 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 = ""
index 04eca305862f4198a7dbbea5aac656892aac1eb4..036549deaa45fbb1d113420fe14d034ee0ef35c9 100644 (file)
@@ -90,6 +90,9 @@ instance MayAttr a => MayAttr (Maybe a) where
 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