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