never executed always true always false
1 module Conjure.Language.AST.Helpers (
2 Parser,
3 makeUnexpected,
4 makeMissing,
5 eSymbol,
6 identifier,
7 need,
8 want,
9 needWeak,
10 commaList,
11 commaList1,
12 parseIdentifier,
13 parseIdentifierStrict,
14 parseMetaVar,
15 intLiteral,
16 parseSequence,
17 parseSequence1,
18 parseList,
19 curlyBracketList,
20 squareBracketList,
21 parenListStrict,
22 parenList,
23 parensPair,
24 parseAttributeLexeme
25 ) where
26
27 import Conjure.Language.AST.Syntax
28 import Conjure.Language.Attributes (allAttributLexemes)
29 import Conjure.Language.Lexemes
30 import Conjure.Language.Lexer
31 import Conjure.Prelude hiding (many)
32 import qualified Data.Set as Set
33 import Data.Void
34 import Text.Megaparsec
35
36 type Parser = (Parsec Void ETokenStream)
37
38 eSymbol :: Lexeme -> Parser ETok
39 eSymbol lx = token test Set.empty <?> "Symbol " ++ show lx
40 where
41 test x
42 | lexeme x == lx = Just x
43 | otherwise = Nothing
44
45 identifier :: Parser ETok
46 identifier = token test Set.empty <?> "Identifier"
47 where
48 test x = case x of
49 ETok{lexeme = (LIdentifier _)} -> Just x
50 ETok{} -> Nothing
51
52 metaVar :: Parser ETok
53 metaVar = token test Set.empty <?> "Metavar"
54 where
55 test x = case x of
56 ETok{lexeme = (LMetaVar _)} -> Just x
57 ETok{} -> Nothing
58
59 anIdent :: Lexeme
60 anIdent = LIdentifier ""
61
62
63 intLiteral :: Parser ETok
64 intLiteral = token test Set.empty <?> "Int Literal"
65 where
66 test x = case x of
67 ETok{lexeme = (LIntLiteral _)} -> Just x
68 ETok{} -> Nothing
69
70 makeMissing :: Lexeme -> Parser LToken
71 makeMissing l = do
72 dummyToken <- lookAhead anySingle
73 return . MissingToken $ nullBefore l dummyToken
74
75 makeUnexpected :: Parser LToken
76 makeUnexpected = SkippedToken <$> anySingle
77
78 -- try to get a token from the stream but allow failiure
79 want :: Lexeme -> Parser LToken
80 want (LIdentifier _) = do
81 tok@(ETok _ _ lex _) <- lookAhead anySingle
82 case lex of
83 (LIdentifier _) -> makeStrict <$> anySingle
84 _ -> return $ MissingToken $ nullBefore LMissingIdentifier tok
85 want a = do
86 tok@(ETok _ _ lex _) <- lookAhead anySingle
87 if lex == a
88 then makeStrict <$> anySingle
89 else return $ MissingToken $ nullBefore a tok
90
91 -- get a symbol from the stream with no fallback
92 need :: Lexeme -> Parser SToken
93 need a = StrictToken [] <$> eSymbol a <?> "\"" ++ lexemeFace a ++ "\""
94
95 -- get a symbol from the stream where it is required but the underlying
96 -- structure does not (e.g. disambiguating a list)
97 needWeak :: Lexeme -> Parser LToken
98 needWeak a = RealToken <$> need a
99
100
101
102 parseIdentifier :: Parser NameNode
103 parseIdentifier = do NameNode <$> parseIdentifierStrict <|> MissingNameNode <$> want anIdent
104
105 parseAttributeLexeme :: Parser SToken
106 parseAttributeLexeme = StrictToken [] <$> token isValid Set.empty
107 where
108 isValid t@(lexeme -> l)
109 | l `elem` allAttributLexemes = Just t
110 | otherwise = Nothing
111
112 parseMetaVar :: Parser SToken
113 parseMetaVar = StrictToken [] <$> metaVar
114
115 parseIdentifierStrict :: Parser NameNodeS
116 parseIdentifierStrict = do
117 NameNodeS . StrictToken [] <$> identifier
118
119 -- List helpers
120
121 commaList :: (Null a, Show a) => Parser a -> Parser (Sequence a)
122 commaList = parseSequence L_Comma
123
124 commaList1 :: (Null a, Show a) => Parser a -> Parser (Sequence a)
125 commaList1 = parseSequence1 L_Comma
126
127 squareBracketList :: Parser (Sequence a) -> Parser (ListNode a)
128 squareBracketList = parseList L_OpenBracket L_CloseBracket
129
130 curlyBracketList :: Parser (Sequence a) -> Parser (ListNode a)
131 curlyBracketList = parseList L_OpenCurly L_CloseCurly
132
133 parenList :: Parser (Sequence a) -> Parser (ListNode a)
134 parenList = parseList L_OpenParen L_CloseParen
135
136 parenListStrict :: Parser (Sequence a) -> Parser (ListNode a)
137 parenListStrict = parseListStrict L_OpenParen L_CloseParen
138
139 parseList :: Lexeme -> Lexeme -> Parser (Sequence a) -> Parser (ListNode a)
140 parseList startB endB seq = do
141 startB' <- want startB
142 vals <- seq
143 endB' <- want endB
144 return $ ListNode startB' vals endB'
145
146 parseListStrict :: Lexeme -> Lexeme -> Parser (Sequence a) -> Parser (ListNode a)
147 parseListStrict startB endB seq = do
148 startB' <- need startB
149 vals <- seq
150 endB' <- want endB
151 return $ ListNode (RealToken startB') vals endB'
152
153 parseSequence1 :: (Null a, Show a) => Lexeme -> Parser a -> Parser (Sequence a)
154 parseSequence1 divider pElem = do
155 s <- parseSequence divider pElem
156 case s of
157 Seq [] -> try $ do
158 q <- pElem
159 return $ Seq [SeqElem q Nothing]
160 Seq _ -> return s
161
162 parseSequence :: (Null a, Show a) => Lexeme -> Parser a -> Parser (Sequence a)
163 parseSequence divider pElem = try $ do
164 missingPlaceholder <- makeMissing $ L_Missing MissingUnknown
165 sElem <- optional pElem
166 sep <- want divider
167 case (sElem, isMissing sep) of
168 (a, True) | isMissing a -> return $ Seq []
169 _ -> do
170 Seq rest <- parseSequence divider pElem
171 makeElem rest sElem sep missingPlaceholder
172 where
173 makeElem rest el sep plc = do
174 let newElem = case (el, isMissing sep) of
175 (Just a, True) -> [SeqElem a $ if null rest then Nothing else Just sep]
176 (a, False) | isMissing a -> [MissingSeqElem plc sep]
177 (Just a, _) -> [SeqElem a $ Just sep]
178 _ -> []
179 return $ Seq $ newElem ++ rest
180
181
182
183 parensPair :: (Lexeme, Lexeme)
184 parensPair = (L_OpenParen, L_CloseParen)
185