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