Lexer.hs 5.04 KB
Newer Older
1
{-# LANGUAGE FlexibleContexts #-}
2
3
{-# LANGUAGE ScopedTypeVariables #-}

4
module Copar.Parser.Lexer
5
6
7
8
9
  ( newlines1
  , newlines
  , newlinesOrEof
  , space
  , space1
10
11
12
13
14
  , symbol
  , lexeme
  , braces
  , parens
  , angles
15
  , brackets
16
17
18
19
20
  , semicolon
  , comma
  , colon
  , dot
  , name
21
22
23
  , decimal
  , float
  , signed
24
  , adouble
25
  , complex
26
  , hex
27
28
  ) where

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
29
import           Data.Char
30
import           Control.Monad
31
32
33
34
import           Data.Complex
import           Control.Applicative
import           Data.Maybe (fromMaybe)
import           Data.Tuple (swap)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
35

36
37
38
import           Data.Text (Text)
import qualified Data.Text as T
import           Text.Megaparsec
39
import           Text.Megaparsec.Char hiding (space, space1, newline)
40
41
import qualified Text.Megaparsec.Char.Lexer as L

42
import           Copar.Parser.Types
43
import           Data.Float.Utils (EqDouble, fromDouble)
44

45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
newline :: MonadParser m => m ()
newline = (void (takeWhile1P (Just "newline") (=='\n'))
          <|> (skipLineComment <* char '\n')) *> space
{-# INLINE newline #-}

-- | Parses newlines or the end of input
newlinesOrEof :: MonadParser m => m ()
newlinesOrEof = newlines1 <|> eof
{-# INLINE newlinesOrEof #-}

-- | Parses one or more newlines or comments
newlines1 :: MonadParser m => m ()
newlines1 = skipSome newline
{-# INLINE newlines1 #-}

-- | Parses zero or more newlines or comments
newlines :: MonadParser m => m ()
newlines = skipMany newline
{-# INLINE newlines #-}

skipLineComment :: MonadParser m => m ()
skipLineComment = char '#' *> void (takeWhileP Nothing (/= '\n'))
{-# INLINE skipLineComment #-}

-- | Parsers zero or more whitespace characters (except newlines)
space :: MonadParser m => m ()
71
space = void (takeWhileP (Just "space") simpleIsSpace)
72
73
74
75
{-# INLINE space #-}

-- | Parsers one or more whitespace characters (except newlines)
space1 :: MonadParser m => m ()
76
space1 = void (takeWhile1P (Just "space") simpleIsSpace)
77
{-# INLINE space1 #-}
78

79
80
81
82
83
84
85
86
-- | Variant of 'isSpace' that doesn't handle unicode space characters and also
-- isn't 'True' for @\n@.
simpleIsSpace :: Char -> Bool
simpleIsSpace ' '  = True
simpleIsSpace '\t' = True
simpleIsSpace _    = False
{-# INLINE simpleIsSpace #-}

87
lexeme :: MonadParser m => m a -> m a
88
lexeme = L.lexeme space
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
89
{-# INLINE lexeme #-}
90

91
symbol :: MonadParser m => Text -> m Text
92
symbol = L.symbol space
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
93
{-# INLINE symbol #-}
94

95
96
97
98
character :: MonadParser m => Char -> m Char
character = lexeme . char
{-# INLINE character #-}

99
braces :: MonadParser m => m a -> m a
100
braces = between (character '{') (character '}')
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
101
{-# INLINE braces #-}
102

103
parens :: MonadParser m => m a -> m a
104
parens = between (character '(') (character ')')
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
105
{-# INLINE parens #-}
106

107
angles :: MonadParser m => m a -> m a
108
angles = between (character '<') (character '>')
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
109
{-# INLINE angles #-}
110

111
brackets :: MonadParser m => m a -> m a
112
brackets = between (character '[') (character ']')
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
113
{-# INLINE brackets #-}
114

115
116
semicolon :: MonadParser m => m Char
semicolon = character ';'
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
117
{-# INLINE semicolon #-}
118

119
120
comma :: MonadParser m => m Char
comma = character ','
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
121
{-# INLINE comma #-}
122

123
124
colon :: MonadParser m => m Char
colon = character ':'
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
125
{-# INLINE colon #-}
126

127
128
dot :: MonadParser m => m Char
dot = character '.'
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
129
{-# INLINE dot #-}
130

131
name :: MonadParser m => m Text
132
name = lexeme ((T.append <$> nameChar1 <*> restName) <?> "name")
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
133
{-# INLINE name #-}
134

135
136
nameChar1 :: MonadParser m => m Text
nameChar1 = takeWhile1P Nothing (\c -> c == '_' || isLetter c)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
137
{-# INLINE nameChar1 #-}
138

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
139
140
141
142
143
restName :: MonadParser m => m Text
restName = takeWhileP Nothing isNameChar
  where
    isNameChar c = c == '_' || isLetter c || isDigit c
{-# INLINE restName #-}
144

Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
145
146
decimal :: (MonadParser m) => m Int
decimal = lexeme (mkNum <$> takeWhile1P (Just "digit") isDigit)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
147
{-# INLINE decimal #-}
148

149
150
151
152
153
154
155
156
float :: (MonadParser m) => m Double
float = lexeme (mkFloat <$> intPart <*> optional fracPart)
  where
    intPart = takeWhile1P (Just "digit") isDigit
    fracPart = char '.' *> intPart
    mkFloat :: Text -> Maybe Text -> Double
    mkFloat i f = (fromIntegral (mkNum i)) +
      (maybe 0.0 (\e -> fromIntegral (mkNum e) * (10.0 ^^ (negate (T.length e)))) f)
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
157
{-# INLINE float #-}
158

159
adouble :: (MonadParser m) => m EqDouble
160
161
162
adouble = fromDouble <$> float
{-# INLINE adouble #-}

163
164
165
166
167
168
mkNum :: Text -> Int
mkNum = T.foldl' step 0
  where
    step a c = a * 10 + digitToInt c
{-# INLINE mkNum #-}

169
signed :: (MonadParser m, Num a) => m a -> m a
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
170
signed p = option id (char '-' *> return negate) <*> p
Hans-Peter Deifel's avatar
Hans-Peter Deifel committed
171
{-# INLINE signed #-}
172
173
174
175
176
177
178
179
180
181
182
183
184
185


complex :: (MonadParser m, Num a) => m a -> m (Complex a)
complex inner =
  try (uncurry (:+) . swap <$> sumOf imag real)
    <|> (uncurry (:+) <$> sumOf real imag)
  where
    real = inner
    imag = inner <* symbol "i"
    mandatorySigned p =
      (symbol "-" *> pure negate <|> symbol "+" *> pure id) <*> p
    optionalNum = fmap (fromMaybe 0) . optional
    sumOf p1 p2 = (,) <$> signed p1 <*> optionalNum (mandatorySigned p2)
{-# INLINE complex #-}
186
187
188
189
190
191
192


-- | Parse a hexadecimal number consisting of the prefix "0x" followed by
-- hexadecimal digits (both upper and lower case).
hex :: (MonadParser m, Integral a) => m a
hex = lexeme (string "0x" *> L.hexadecimal)
{-# INLINE hex #-}