]> Git — Sourcephile - doclang.git/blob - Language/TCT/Read/Tree.hs
Add Html5ify for TCT.
[doclang.git] / Language / TCT / Read / Tree.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE Rank2Types #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TupleSections #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE ViewPatterns #-}
8 module Language.TCT.Read.Tree where
9
10 import Control.Applicative (Applicative(..), Alternative(..))
11 import Control.Monad (Monad(..), void)
12 import Data.Bool
13 import Data.Eq (Eq(..))
14 import Data.Function (($), (.))
15 import Data.Functor ((<$>), ($>), (<$))
16 import Data.Monoid (Monoid(..))
17 import Data.Semigroup (Semigroup(..))
18 import Data.String (IsString(..))
19 import Data.Text (Text)
20 import Data.TreeSeq.Strict (Tree(..), Trees)
21 import Prelude (undefined, Num(..))
22 import qualified Data.Char as Char
23 import qualified Data.List as List
24 import qualified Data.Sequence as Seq
25 import qualified Data.Text as Text
26 import qualified Text.Megaparsec as P
27 import qualified Text.Megaparsec.Char as P
28
29 import Language.TCT.Cell
30 import Language.TCT.Token
31 import Language.TCT.Tree
32 import Language.TCT.Read.Cell
33 import Language.TCT.Read.Elem
34
35 p_CellKey :: Row -> Parser e s Row
36 p_CellKey row = pdbg "CellKey" $ do
37 P.skipMany $ P.char ' '
38 pos <- p_Position
39 key <- pdbg "Key" $
40 P.choice $
41 [ P.try $ P.char '-' >>
42 P.char ' ' $> KeyDash <|>
43 P.string "- " $> KeyDashDash
44 , P.try $ KeyDot . Text.pack
45 <$> P.some (P.satisfy Char.isDigit)
46 <* P.char '.'
47 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
48 , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
49 return $ KeySection $ List.length hs
50 , P.try $
51 KeyBrackets
52 <$> P.between (P.string "[") (P.string "]") p_Name
53 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy (=='\n')))
54 , P.try $
55 (\f -> KeyDotSlash $ "./"<>f)
56 <$ P.string "./"
57 <*> P.many (P.satisfy (/='\n'))
58 , do
59 name <- p_Name
60 wh <- Text.pack <$> P.many (P.char ' ')
61 P.choice
62 [ P.try $ KeyColon name wh
63 <$ P.char ':'
64 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
65 , P.char '>' $> KeyGreat name wh
66 , P.char '=' $> KeyEqual name wh
67 , P.char '|' $> KeyBar name wh
68 ]
69 ]
70 posEnd <- p_Position
71 let row' = TreeN (Cell pos posEnd key) mempty : row
72 case key of
73 KeySection{} -> p_CellEnd row'
74 KeyDash{} -> p_Row row'
75 KeyDashDash{} -> p_CellText row'
76 KeyDot{} -> p_Row row'
77 KeyColon{} -> p_Row row'
78 KeyBrackets{} -> p_Row row'
79 KeyGreat{} -> p_Row row'
80 KeyEqual{} -> p_CellEnd row'
81 KeyBar{} -> p_CellEnd row'
82 KeyDotSlash{} -> p_CellEnd row'
83 KeyLower{} -> undefined -- NOTE: handled in 'p_CellLower'
84
85 p_Name :: Parser e s Name
86 p_Name =
87 (\h t -> Text.pack (h:t))
88 <$> (P.satisfy $ \c ->
89 Char.isAlphaNum c || c=='_')
90 <*> many (P.satisfy $ \c ->
91 Char.isAlphaNum c || c=='-' || c=='_')
92
93 p_Line :: Parser e s Text
94 p_Line = Text.pack <$> P.many (P.satisfy (/='\n'))
95
96 p_CellLower :: forall e s. Row -> Parser e s Row
97 p_CellLower row = pdbg "CellLower" $ do
98 P.skipMany $ P.char ' '
99 pos <- p_Position
100 void $ P.char '<'
101 name <- p_Name
102 attrs <- p_attrs
103 posClose <- p_Position
104 let treeHere =
105 TreeN (Cell pos posClose $ KeyLower name attrs) .
106 Seq.singleton . Tree0
107 let treeElem toks (Cell _ p c) =
108 let (o,_) = pairBorders (PairElem name attrs) toks in
109 Tree0 $ Cell pos p (o<>c)
110 let indent = fromString $ List.replicate (columnPos pos - 1) ' '
111 tree <-
112 P.try (P.char '>' >> treeElem (tokens [cell0 $ TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|>
113 P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|>
114 P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|>
115 (P.eof $> treeHere (Cell posClose posClose ""))
116 return (tree:row)
117 where
118 p_attrs = P.many $ P.try $
119 (,)
120 <$> (Text.pack <$> P.some (P.char ' '))
121 <*> p_Attr
122 p_CellLine :: Parser e s (Cell Text)
123 p_CellLine = do
124 pos <- p_Position
125 content <- p_Line
126 posEnd <- p_Position
127 return $ Cell pos posEnd content
128 p_CellLines :: P.Tokens s -> Parser e s (Cell Text)
129 p_CellLines indent = do
130 pos <- p_Position
131 content <-
132 Text.intercalate "\n"
133 <$> P.sepBy (P.try p_Line) (P.try $ P.char '\n' >> P.string indent)
134 posEnd <- p_Position
135 return $ Cell pos posEnd content
136 p_CellLinesUntilElemEnd :: P.Tokens s -> Text -> Parser e s (Cell Text)
137 p_CellLinesUntilElemEnd indent name = do
138 pos <- p_Position
139 content <- Text.intercalate "\n" . List.reverse <$> go []
140 posEnd <- p_Position
141 return $ Cell pos posEnd content
142 where
143 go :: [Text] -> Parser e s [Text]
144 go ls =
145 P.try ((\w l -> Text.pack w <> "</" <> name <> l : ls)
146 <$> P.many (P.char ' ')
147 <* P.string (fromString $ "</"<>Text.unpack name)
148 <*> p_Line) <|>
149 (p_Line >>= \l -> P.try $
150 P.char '\n' >>
151 P.string indent >>
152 go (l:ls))
153
154 p_CellText :: Row -> Parser e s Row
155 p_CellText row = pdbg "CellText" $ do
156 P.skipMany $ P.char ' '
157 pos <- p_Position
158 line <- Text.pack <$> P.some (P.satisfy (/='\n'))
159 posEnd <- p_Position
160 return $ Tree0 (Cell pos posEnd line) : row
161
162 p_CellSpaces :: Row -> Parser e s Row
163 p_CellSpaces row = pdbg "CellSpaces" $ do
164 P.skipSome $ P.char ' '
165 pos <- p_Position
166 return $ Tree0 (Cell pos pos "") : row
167
168 p_CellEnd :: Row -> Parser e s Row
169 p_CellEnd row = pdbg "Row" $
170 P.try (p_CellLower row) <|>
171 P.try (p_CellText row) <|>
172 p_CellSpaces row <|>
173 return row
174
175 p_Row :: Row -> Parser e s Row
176 p_Row row = pdbg "Row" $
177 P.try (p_CellKey row) <|>
178 p_CellEnd row
179
180 p_Rows :: Rows -> Parser e s Rows
181 p_Rows rows =
182 p_Row [] >>= \row ->
183 let rows' = appendRow rows (List.reverse row) in
184 (P.eof $> rows') <|>
185 (P.newline >> p_Rows rows')
186
187 p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
188 p_Trees = unRoot . collapseRows <$> p_Rows [root]
189 where
190 root = TreeN (cell0 KeyDashDash) mempty
191 unRoot (TreeN (unCell -> KeyDashDash) roots) = roots
192 unRoot _ = undefined