{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Docs.LTML
( treeToMeta
, treeToMeta'
, treeRevisionToLtmlInputTree
, nodeToLtmlInputTree
, nodeToLtmlInputTreePred
, nodeToLtmlInputTree'
, treeToLtmlInputTree
, treeRevisionToMeta
) where
import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as BL
import Data.Maybe (mapMaybe)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TE
import Docs.TextElement (TextElement)
import Docs.TextRevision
( TextElementRevision (TextElementRevision)
)
import Docs.Tree (Node (Node), NodeHeader, Tree (Leaf, Tree))
import qualified Docs.Tree as Tree
import Control.Monad (mfilter)
import Docs.MetaTree
( Meta (Meta)
, MetaNode (MetaNode)
, MetaTree (MetaLeaf, MetaTree)
, TocEntry (TocEntry)
, TreeRevisionWithMetaData (TreeRevisionWithMetaData)
, TreeWithMetaData (TreeWithMetaData)
)
import qualified Docs.MetaTree as MetaTree
import Docs.Renderable (Renderable (contentOf, kindOf, typeOf))
import qualified Docs.TextRevision as TextRevision
import Docs.TreeRevision (TreeRevision (TreeRevision))
import qualified Language.Lsd.AST.Common as LSD
import qualified Language.Ltml.Common as LTML
import Language.Ltml.Tree (FlaggedInputTree)
import qualified Language.Ltml.Tree as LTML
import qualified Language.Ltml.Tree.ToMeta as LTML
treeRevisionToMeta
:: (Renderable r)
=> TreeRevision r
-> Either LTML.MetaError (TreeRevisionWithMetaData r)
treeRevisionToMeta :: forall r.
Renderable r =>
TreeRevision r -> Either MetaError (TreeRevisionWithMetaData r)
treeRevisionToMeta (TreeRevision TreeRevisionHeader
header Node r
root) =
TreeRevisionHeader
-> TreeWithMetaData r -> TreeRevisionWithMetaData r
forall a.
TreeRevisionHeader
-> TreeWithMetaData a -> TreeRevisionWithMetaData a
TreeRevisionWithMetaData TreeRevisionHeader
header (TreeWithMetaData r -> TreeRevisionWithMetaData r)
-> Either MetaError (TreeWithMetaData r)
-> Either MetaError (TreeRevisionWithMetaData r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node r -> Either MetaError (TreeWithMetaData r)
forall r.
Renderable r =>
Node r -> Either MetaError (TreeWithMetaData r)
treeToMeta Node r
root
treeToMeta'
:: Node TextElementRevision
-> Either LTML.MetaError (TreeWithMetaData TextElement)
treeToMeta' :: Node TextElementRevision
-> Either MetaError (TreeWithMetaData TextElement)
treeToMeta' Node TextElementRevision
input = (TextElementRevision -> TextElement
TextRevision.textElement (TextElementRevision -> TextElement)
-> TreeWithMetaData TextElementRevision
-> TreeWithMetaData TextElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (TreeWithMetaData TextElementRevision
-> TreeWithMetaData TextElement)
-> Either MetaError (TreeWithMetaData TextElementRevision)
-> Either MetaError (TreeWithMetaData TextElement)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node TextElementRevision
-> Either MetaError (TreeWithMetaData TextElementRevision)
forall r.
Renderable r =>
Node r -> Either MetaError (TreeWithMetaData r)
treeToMeta Node TextElementRevision
input
treeToMeta
:: (Renderable r)
=> Node r
-> Either LTML.MetaError (TreeWithMetaData r)
treeToMeta :: forall r.
Renderable r =>
Node r -> Either MetaError (TreeWithMetaData r)
treeToMeta Node r
input =
let ltmlMeta :: Either MetaError (Maybe (Meta r), Map FullTypeName ProperTypeMeta)
ltmlMeta =
(FlaggedMetaTree (MetaFlag r) -> Maybe (Meta r))
-> (FlaggedMetaTree (MetaFlag r), Map FullTypeName ProperTypeMeta)
-> (Maybe (Meta r), Map FullTypeName ProperTypeMeta)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first FlaggedMetaTree (MetaFlag r) -> Maybe (Meta r)
forall a. FlaggedMetaTree (MetaFlag a) -> Maybe (Meta a)
treeFromFlaggedMetaTree
((FlaggedMetaTree (MetaFlag r), Map FullTypeName ProperTypeMeta)
-> (Maybe (Meta r), Map FullTypeName ProperTypeMeta))
-> Either
MetaError
(FlaggedMetaTree (MetaFlag r), Map FullTypeName ProperTypeMeta)
-> Either
MetaError (Maybe (Meta r), Map FullTypeName ProperTypeMeta)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FlaggedInputTree (MetaFlag r)
-> Either
MetaError
(FlaggedMetaTree (MetaFlag r), Map FullTypeName ProperTypeMeta)
forall ident.
FlaggedInputTree ident
-> Either
MetaError (FlaggedMetaTree ident, Map FullTypeName ProperTypeMeta)
LTML.treeToMeta (Node r -> FlaggedInputTree (MetaFlag r)
forall r. Renderable r => Node r -> FlaggedInputTree (MetaFlag r)
nodeToLtmlInputTree Node r
input)
in case Either MetaError (Maybe (Meta r), Map FullTypeName ProperTypeMeta)
ltmlMeta of
Left MetaError
err -> MetaError -> Either MetaError (TreeWithMetaData r)
forall a b. a -> Either a b
Left MetaError
err
Right (Just Meta r
tree, Map FullTypeName ProperTypeMeta
metaMap) ->
TreeWithMetaData r -> Either MetaError (TreeWithMetaData r)
forall a b. b -> Either a b
Right (TreeWithMetaData r -> Either MetaError (TreeWithMetaData r))
-> TreeWithMetaData r -> Either MetaError (TreeWithMetaData r)
forall a b. (a -> b) -> a -> b
$
TreeWithMetaData
{ root :: Meta r
MetaTree.root = Meta r
tree
, metaMap :: Map FullTypeName ProperTypeMeta
MetaTree.metaMap = Map FullTypeName ProperTypeMeta
metaMap
}
Right (Maybe (Meta r)
Nothing, Map FullTypeName ProperTypeMeta
_) -> MetaError -> Either MetaError (TreeWithMetaData r)
forall a b. a -> Either a b
Left (MetaError -> Either MetaError (TreeWithMetaData r))
-> MetaError -> Either MetaError (TreeWithMetaData r)
forall a b. (a -> b) -> a -> b
$ String -> MetaError
LTML.MetaBug String
"Wurzel ist nich da :/"
data MetaFlag a
= TreeFlag NodeHeader
| LeafFlag a
instance Functor MetaFlag where
fmap :: forall a b. (a -> b) -> MetaFlag a -> MetaFlag b
fmap a -> b
f (LeafFlag a
x) = b -> MetaFlag b
forall a. a -> MetaFlag a
LeafFlag (b -> MetaFlag b) -> b -> MetaFlag b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x
fmap a -> b
_ (TreeFlag NodeHeader
x) = NodeHeader -> MetaFlag b
forall a. NodeHeader -> MetaFlag a
TreeFlag NodeHeader
x
treeFromFlaggedMetaTree
:: LTML.FlaggedMetaTree (MetaFlag a)
-> Maybe (Meta a)
treeFromFlaggedMetaTree :: forall a. FlaggedMetaTree (MetaFlag a) -> Maybe (Meta a)
treeFromFlaggedMetaTree
(LTML.Flagged MetaFlag a
flag (LTML.TypedTree KindName
_ TypeName
_ Tree (MetaFlag a) RenderedTocEntry RenderedTocEntry
tree)) = case (MetaFlag a
flag, Tree (MetaFlag a) RenderedTocEntry RenderedTocEntry
tree) of
(TreeFlag NodeHeader
header, LTML.Tree RenderedTocEntry
tocEntry [Flagged
(MetaFlag a)
(TypedTree (MetaFlag a) RenderedTocEntry RenderedTocEntry)]
xs) ->
Meta a -> Maybe (Meta a)
forall a. a -> Maybe a
Just (Meta a -> Maybe (Meta a)) -> Meta a -> Maybe (Meta a)
forall a b. (a -> b) -> a -> b
$
Meta
{ meta :: TocEntry
MetaTree.meta = RenderedTocEntry -> TocEntry
toTocEntry RenderedTocEntry
tocEntry
, tree :: MetaTree a
MetaTree.tree =
MetaNode a -> MetaTree a
forall a. MetaNode a -> MetaTree a
MetaTree (MetaNode a -> MetaTree a) -> MetaNode a -> MetaTree a
forall a b. (a -> b) -> a -> b
$
MetaNode
{ header :: NodeHeader
MetaTree.header = NodeHeader
header
, children :: [Meta a]
MetaTree.children =
Flagged
(MetaFlag a)
(TypedTree (MetaFlag a) RenderedTocEntry RenderedTocEntry)
-> Maybe (Meta a)
forall a. FlaggedMetaTree (MetaFlag a) -> Maybe (Meta a)
treeFromFlaggedMetaTree (Flagged
(MetaFlag a)
(TypedTree (MetaFlag a) RenderedTocEntry RenderedTocEntry)
-> Maybe (Meta a))
-> [Flagged
(MetaFlag a)
(TypedTree (MetaFlag a) RenderedTocEntry RenderedTocEntry)]
-> [Meta a]
forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe` [Flagged
(MetaFlag a)
(TypedTree (MetaFlag a) RenderedTocEntry RenderedTocEntry)]
xs
}
}
(LeafFlag a
x, LTML.Leaf RenderedTocEntry
tocEntry) ->
Meta a -> Maybe (Meta a)
forall a. a -> Maybe a
Just (Meta a -> Maybe (Meta a)) -> Meta a -> Maybe (Meta a)
forall a b. (a -> b) -> a -> b
$
Meta
{ meta :: TocEntry
MetaTree.meta = RenderedTocEntry -> TocEntry
toTocEntry RenderedTocEntry
tocEntry
, tree :: MetaTree a
MetaTree.tree = a -> MetaTree a
forall a. a -> MetaTree a
MetaLeaf a
x
}
(MetaFlag a, Tree (MetaFlag a) RenderedTocEntry RenderedTocEntry)
_ -> Maybe (Meta a)
forall a. Maybe a
Nothing
where
toTocEntry :: RenderedTocEntry -> TocEntry
toTocEntry RenderedTocEntry
tocEntry =
let toText :: LazyByteString -> Maybe Text
toText =
(UnicodeException -> Maybe Text)
-> (Text -> Maybe Text)
-> Either UnicodeException Text
-> Maybe Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Text -> UnicodeException -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing) Text -> Maybe Text
forall a. a -> Maybe a
Just (Either UnicodeException Text -> Maybe Text)
-> (LazyByteString -> Either UnicodeException Text)
-> LazyByteString
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
TE.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> (LazyByteString -> ByteString)
-> LazyByteString
-> Either UnicodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> ByteString
BL.toStrict
label :: Maybe Text
label = RenderedTocEntry -> Maybe LazyByteString
forall a b. (a, b) -> a
fst RenderedTocEntry
tocEntry Maybe LazyByteString
-> (LazyByteString -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LazyByteString -> Maybe Text
toText
title :: Result (Maybe Text)
title = LazyByteString -> Maybe Text
toText (LazyByteString -> Maybe Text)
-> Result LazyByteString -> Result (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RenderedTocEntry -> Result LazyByteString
forall a b. (a, b) -> b
snd RenderedTocEntry
tocEntry
in TocEntry
{ label :: Maybe Text
MetaTree.label = Maybe Text
label
, title :: Result (Maybe Text)
MetaTree.title = Result (Maybe Text)
title
}
treeRevisionToLtmlInputTree
:: (Renderable r)
=> TreeRevision r
-> FlaggedInputTree (MetaFlag r)
treeRevisionToLtmlInputTree :: forall r.
Renderable r =>
TreeRevision r -> FlaggedInputTree (MetaFlag r)
treeRevisionToLtmlInputTree (TreeRevision TreeRevisionHeader
_ Node r
node) = Node r -> FlaggedInputTree (MetaFlag r)
forall r. Renderable r => Node r -> FlaggedInputTree (MetaFlag r)
nodeToLtmlInputTree Node r
node
nodeToLtmlInputTree'
:: Node TextElementRevision
-> FlaggedInputTree (MetaFlag TextElement)
nodeToLtmlInputTree' :: Node TextElementRevision -> FlaggedInputTree (MetaFlag TextElement)
nodeToLtmlInputTree' =
(MetaFlag TextElementRevision -> MetaFlag TextElement)
-> (Maybe Text -> Maybe Text)
-> (Text -> Text)
-> FlaggedTree (MetaFlag TextElementRevision) (Maybe Text) Text
-> FlaggedInputTree (MetaFlag TextElement)
forall fl fl' a a' b b'.
(fl -> fl')
-> (a -> a')
-> (b -> b')
-> FlaggedTree fl a b
-> FlaggedTree fl' a' b'
LTML.flaggedTreeMap
((\(TextElementRevision TextElement
te Maybe TextRevision
_) -> TextElement
te) (TextElementRevision -> TextElement)
-> MetaFlag TextElementRevision -> MetaFlag TextElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
Maybe Text -> Maybe Text
forall a. a -> a
id
Text -> Text
forall a. a -> a
id
(FlaggedTree (MetaFlag TextElementRevision) (Maybe Text) Text
-> FlaggedInputTree (MetaFlag TextElement))
-> (Node TextElementRevision
-> FlaggedTree (MetaFlag TextElementRevision) (Maybe Text) Text)
-> Node TextElementRevision
-> FlaggedInputTree (MetaFlag TextElement)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node TextElementRevision
-> FlaggedTree (MetaFlag TextElementRevision) (Maybe Text) Text
forall r. Renderable r => Node r -> FlaggedInputTree (MetaFlag r)
nodeToLtmlInputTree
nodeToLtmlInputTreePred
:: (Renderable r)
=> (NodeHeader -> Bool)
-> (r -> Bool)
-> Node r
-> FlaggedInputTree Bool
nodeToLtmlInputTreePred :: forall r.
Renderable r =>
(NodeHeader -> Bool)
-> (r -> Bool) -> Node r -> FlaggedInputTree Bool
nodeToLtmlInputTreePred NodeHeader -> Bool
treePred r -> Bool
leafPred =
(MetaFlag r -> Bool)
-> (Maybe Text -> Maybe Text)
-> (Text -> Text)
-> FlaggedTree (MetaFlag r) (Maybe Text) Text
-> FlaggedInputTree Bool
forall fl fl' a a' b b'.
(fl -> fl')
-> (a -> a')
-> (b -> b')
-> FlaggedTree fl a b
-> FlaggedTree fl' a' b'
LTML.flaggedTreeMap
MetaFlag r -> Bool
pred'
Maybe Text -> Maybe Text
forall a. a -> a
id
Text -> Text
forall a. a -> a
id
(FlaggedTree (MetaFlag r) (Maybe Text) Text
-> FlaggedInputTree Bool)
-> (Node r -> FlaggedTree (MetaFlag r) (Maybe Text) Text)
-> Node r
-> FlaggedInputTree Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node r -> FlaggedTree (MetaFlag r) (Maybe Text) Text
forall r. Renderable r => Node r -> FlaggedInputTree (MetaFlag r)
nodeToLtmlInputTree
where
pred' :: MetaFlag r -> Bool
pred' (TreeFlag NodeHeader
t) = NodeHeader -> Bool
treePred NodeHeader
t
pred' (LeafFlag r
l) = r -> Bool
leafPred r
l
nodeToLtmlInputTree
:: (Renderable r)
=> Node r
-> FlaggedInputTree (MetaFlag r)
nodeToLtmlInputTree :: forall r. Renderable r => Node r -> FlaggedInputTree (MetaFlag r)
nodeToLtmlInputTree (Node {NodeHeader
header :: NodeHeader
header :: forall a. Node a -> NodeHeader
Tree.header, [Tree r]
children :: [Tree r]
children :: forall a. Node a -> [Tree a]
Tree.children}) =
let kind :: KindName
kind = String -> KindName
LSD.KindName (String -> KindName) -> String -> KindName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ NodeHeader -> Text
Tree.headerKind NodeHeader
header
type_ :: TypeName
type_ = String -> TypeName
LSD.TypeName (String -> TypeName) -> String -> TypeName
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ NodeHeader -> Text
Tree.headerType NodeHeader
header
heading :: Maybe Text
heading = (Text -> Bool) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a. MonadPlus m => (a -> Bool) -> m a -> m a
mfilter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") (Maybe Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ NodeHeader -> Maybe Text
Tree.heading NodeHeader
header
in MetaFlag r
-> TypedTree (MetaFlag r) (Maybe Text) Text
-> Flagged (MetaFlag r) (TypedTree (MetaFlag r) (Maybe Text) Text)
forall flag a. flag -> a -> Flagged flag a
LTML.Flagged
(NodeHeader -> MetaFlag r
forall a. NodeHeader -> MetaFlag a
TreeFlag NodeHeader
header)
(TypedTree (MetaFlag r) (Maybe Text) Text
-> Flagged (MetaFlag r) (TypedTree (MetaFlag r) (Maybe Text) Text))
-> TypedTree (MetaFlag r) (Maybe Text) Text
-> Flagged (MetaFlag r) (TypedTree (MetaFlag r) (Maybe Text) Text)
forall a b. (a -> b) -> a -> b
$ KindName
-> TypeName
-> Tree (MetaFlag r) (Maybe Text) Text
-> TypedTree (MetaFlag r) (Maybe Text) Text
forall flag a b.
KindName -> TypeName -> Tree flag a b -> TypedTree flag a b
LTML.TypedTree KindName
kind TypeName
type_
(Tree (MetaFlag r) (Maybe Text) Text
-> TypedTree (MetaFlag r) (Maybe Text) Text)
-> Tree (MetaFlag r) (Maybe Text) Text
-> TypedTree (MetaFlag r) (Maybe Text) Text
forall a b. (a -> b) -> a -> b
$ Maybe Text
-> [Flagged
(MetaFlag r) (TypedTree (MetaFlag r) (Maybe Text) Text)]
-> Tree (MetaFlag r) (Maybe Text) Text
forall flag a b. a -> [FlaggedTree flag a b] -> Tree flag a b
LTML.Tree Maybe Text
heading
([Flagged (MetaFlag r) (TypedTree (MetaFlag r) (Maybe Text) Text)]
-> Tree (MetaFlag r) (Maybe Text) Text)
-> [Flagged
(MetaFlag r) (TypedTree (MetaFlag r) (Maybe Text) Text)]
-> Tree (MetaFlag r) (Maybe Text) Text
forall a b. (a -> b) -> a -> b
$ Tree r
-> Flagged (MetaFlag r) (TypedTree (MetaFlag r) (Maybe Text) Text)
forall r. Renderable r => Tree r -> FlaggedInputTree (MetaFlag r)
treeToLtmlInputTree (Tree r
-> Flagged (MetaFlag r) (TypedTree (MetaFlag r) (Maybe Text) Text))
-> [Tree r]
-> [Flagged
(MetaFlag r) (TypedTree (MetaFlag r) (Maybe Text) Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree r]
children
treeToLtmlInputTree
:: (Renderable r)
=> Tree r
-> FlaggedInputTree (MetaFlag r)
treeToLtmlInputTree :: forall r. Renderable r => Tree r -> FlaggedInputTree (MetaFlag r)
treeToLtmlInputTree (Tree Node r
node) = Node r -> FlaggedInputTree (MetaFlag r)
forall r. Renderable r => Node r -> FlaggedInputTree (MetaFlag r)
nodeToLtmlInputTree Node r
node
treeToLtmlInputTree (Leaf r
element) =
MetaFlag r
-> TypedTree (MetaFlag r) (Maybe Text) Text
-> FlaggedInputTree (MetaFlag r)
forall flag a. flag -> a -> Flagged flag a
LTML.Flagged (r -> MetaFlag r
forall a. a -> MetaFlag a
LeafFlag r
element) (TypedTree (MetaFlag r) (Maybe Text) Text
-> FlaggedInputTree (MetaFlag r))
-> TypedTree (MetaFlag r) (Maybe Text) Text
-> FlaggedInputTree (MetaFlag r)
forall a b. (a -> b) -> a -> b
$
KindName
-> TypeName
-> Tree (MetaFlag r) (Maybe Text) Text
-> TypedTree (MetaFlag r) (Maybe Text) Text
forall flag a b.
KindName -> TypeName -> Tree flag a b -> TypedTree flag a b
LTML.TypedTree (r -> KindName
forall r. Renderable r => r -> KindName
kindOf r
element) (r -> TypeName
forall r. Renderable r => r -> TypeName
typeOf r
element) (Tree (MetaFlag r) (Maybe Text) Text
-> TypedTree (MetaFlag r) (Maybe Text) Text)
-> Tree (MetaFlag r) (Maybe Text) Text
-> TypedTree (MetaFlag r) (Maybe Text) Text
forall a b. (a -> b) -> a -> b
$
Text -> Tree (MetaFlag r) (Maybe Text) Text
forall flag a b. b -> Tree flag a b
LTML.Leaf (Text -> Tree (MetaFlag r) (Maybe Text) Text)
-> Text -> Tree (MetaFlag r) (Maybe Text) Text
forall a b. (a -> b) -> a -> b
$
r -> Text
forall r. Renderable r => r -> Text
contentOf r
element