]> Git — Sourcephile - doclang.git/blob - Language/TCT/Read/Tree.hs
Add KeyDot.
[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.string "- " $> KeyDash
50 , P.try $ KeyDot . Text.pack
51 <$> P.some (P.satisfy Char.isDigit)
52 <* P.char '.'
53 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
54 -- TODO: KeyComment
55 , P.try $ P.some (P.char '#') <* P.lookAhead (P.try $ P.char ' ') >>= \hs ->
56 return $ KeySection $ List.length hs
57 , do
58 name <- p_Name
59 wh <- Text.pack <$> P.many (P.char ' ')
60 P.choice
61 [ P.try $ KeyColon name wh
62 <$ P.char ':'
63 <* P.lookAhead (P.try $ P.eof <|> void (P.satisfy $ \c -> c=='\n'||c==' '))
64 , P.char '>' $> KeyGreat name wh
65 , P.char '=' $> KeyEqual name wh
66 , P.char '|' $> KeyBar name wh
67 -- TODO: KeyAt
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 KeyDot{} -> p_Row row'
76 KeyColon{} -> p_Row row'
77 KeyGreat{} -> p_Row row'
78 KeyEqual{} -> p_CellEnd row'
79 KeyBar{} -> p_CellEnd row'
80 KeyLower{} -> undefined -- NOTE: handled in 'p_CellLower'
81
82 p_Name :: Parser e s Name
83 p_Name =
84 (\h t -> Text.pack (h:t))
85 <$> (P.satisfy $ \c ->
86 Char.isAlphaNum c || c=='_')
87 <*> many (P.satisfy $ \c ->
88 Char.isAlphaNum c || c=='-' || c=='_')
89
90 p_CellLower :: Row -> Parser e s Row
91 p_CellLower row = pdbg "CellLower" $ do
92 P.skipMany $ P.char ' '
93 pos <- p_Position
94 void $ P.char '<'
95 name <- p_Name
96 attrs <- p_attrs
97 posClose <- p_Position
98 let treeHere =
99 TreeN (Cell pos posClose $ KeyLower name attrs) .
100 Seq.singleton . Tree0
101 let treeElem toks (Cell _ p c) =
102 let (o,_) = pairBorders (PairElem name attrs) toks in
103 Tree0 $ Cell pos p (o<>c)
104 let indent = List.replicate (columnPos pos - 1) ' '
105 tree <-
106 P.try (P.char '>' >> treeElem (tokens [TokenPlain ""]) <$> p_CellLinesUntilElemEnd indent name) <|>
107 P.try (P.char '\n' >> P.string indent >> treeHere <$> p_CellLines indent) <|>
108 P.try (P.string "/>" >> treeElem mempty <$> p_CellLine) <|>
109 (P.eof $> treeHere (Cell posClose posClose ""))
110 return (tree:row)
111 where
112 p_attrs = P.many $ P.try $
113 (,)
114 <$> (Text.pack <$> P.some (P.char ' '))
115 <*> p_Attr
116 p_line :: Parser e s Text
117 p_line = Text.pack <$> P.many (P.satisfy (/='\n'))
118 p_CellLine :: Parser e s (Cell Text)
119 p_CellLine = do
120 pos <- p_Position
121 content <- p_line
122 posEnd <- p_Position
123 return $ Cell pos posEnd content
124 p_CellLines :: String -> Parser e s (Cell Text)
125 p_CellLines indent = do
126 pos <- p_Position
127 content <-
128 Text.intercalate "\n"
129 <$> P.sepBy (P.try p_line) (P.try $ P.char '\n' >> P.string indent)
130 posEnd <- p_Position
131 return $ Cell pos posEnd content
132 p_CellLinesUntilElemEnd :: String -> Text -> Parser e s (Cell Text)
133 p_CellLinesUntilElemEnd indent name = do
134 pos <- p_Position
135 content <- Text.intercalate "\n" . List.reverse <$> go []
136 posEnd <- p_Position
137 return $ Cell pos posEnd content
138 where
139 go :: [Text] -> Parser e s [Text]
140 go ls =
141 P.try ((\w p l -> Text.pack w <> Text.pack p <> l : ls)
142 <$> P.many (P.char ' ')
143 <*> P.string ("</"<>Text.unpack name)
144 <*> p_line) <|>
145 (p_line >>= \l -> P.try $
146 P.char '\n' >>
147 P.string indent >>
148 go (l:ls))
149
150 p_CellText :: Row -> Parser e s Row
151 p_CellText row = pdbg "CellText" $ do
152 P.skipMany $ P.char ' '
153 pos <- p_Position
154 line <- Text.pack <$> P.some (P.satisfy (/='\n'))
155 posEnd <- p_Position
156 return $ Tree0 (Cell pos posEnd line) : row
157
158 p_CellSpaces :: Row -> Parser e s Row
159 p_CellSpaces row = pdbg "CellSpaces" $ do
160 P.skipSome $ P.char ' '
161 pos <- p_Position
162 return $ Tree0 (Cell pos pos "") : row
163
164 p_CellEnd :: Row -> Parser e s Row
165 p_CellEnd row = pdbg "Row" $
166 P.try (p_CellLower row) <|>
167 P.try (p_CellText row) <|>
168 p_CellSpaces row <|>
169 return row
170
171 p_Row :: Row -> Parser e s Row
172 p_Row row = pdbg "Row" $
173 P.try (p_CellKey row) <|>
174 p_CellEnd row
175
176 p_Rows :: Rows -> Parser e s Rows
177 p_Rows rows =
178 p_Row [] >>= \row ->
179 let rows' = appendRow rows (List.reverse row) in
180 (P.eof $> rows') <|>
181 (P.newline >> p_Rows rows')
182
183 p_Trees :: Parser e s (Trees (Cell Key) (Cell Text))
184 p_Trees = unRoot . collapseRows <$> p_Rows [root]
185 where
186 root = TreeN (Cell pos0 pos0 KeyDash) mempty
187 unRoot (TreeN (unCell -> KeyDash) roots) = roots
188 unRoot _ = undefined