1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE BangPatterns, UnboxedTuples, OverloadedStrings #-}
3module Parse.Space
4  ( Parser
5  --
6  , chomp
7  , chompAndCheckIndent
8  --
9  , checkIndent
10  , checkAligned
11  , checkFreshLine
12  --
13  , docComment
14  )
15  where
16
17
18import Data.Word (Word8, Word16)
19import Foreign.Ptr (Ptr, plusPtr, minusPtr)
20import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
21
22import qualified AST.Source as Src
23import Parse.Primitives (Row, Col)
24import qualified Parse.Primitives as P
25import qualified Reporting.Annotation as A
26import qualified Reporting.Error.Syntax as E
27
28
29
30-- SPACE PARSING
31
32
33type Parser x a =
34  P.Parser x (a, A.Position)
35
36
37
38-- CHOMP
39
40
41chomp :: (E.Space -> Row -> Col -> x) -> P.Parser x ()
42chomp toError =
43  P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
44    let
45      (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
46    in
47    case status of
48      Good ->
49        let
50          !newState = P.State src newPos end indent newRow newCol
51        in
52        cok () newState
53
54      HasTab               -> cerr newRow newCol (toError E.HasTab)
55      EndlessMultiComment  -> cerr newRow newCol (toError E.EndlessMultiComment)
56
57
58
59-- CHECKS -- to be called right after a `chomp`
60
61
62checkIndent :: A.Position -> (Row -> Col -> x) -> P.Parser x ()
63checkIndent (A.Position endRow endCol) toError =
64  P.Parser $ \state@(P.State _ _ _ indent _ col) _ eok _ eerr ->
65    if col > indent && col > 1
66    then eok () state
67    else eerr endRow endCol toError
68
69
70checkAligned :: (Word16 -> Row -> Col -> x) -> P.Parser x ()
71checkAligned toError =
72  P.Parser $ \state@(P.State _ _ _ indent row col) _ eok _ eerr ->
73    if col == indent
74    then eok () state
75    else eerr row col (toError indent)
76
77
78checkFreshLine :: (Row -> Col -> x) -> P.Parser x ()
79checkFreshLine toError =
80  P.Parser $ \state@(P.State _ _ _ _ row col) _ eok _ eerr ->
81    if col == 1
82    then eok () state
83    else eerr row col toError
84
85
86
87-- CHOMP AND CHECK
88
89
90chompAndCheckIndent :: (E.Space -> Row -> Col -> x) -> (Row -> Col -> x) -> P.Parser x ()
91chompAndCheckIndent toSpaceError toIndentError =
92  P.Parser $ \(P.State src pos end indent row col) cok _ cerr _ ->
93    let
94      (# status, newPos, newRow, newCol #) = eatSpaces pos end row col
95    in
96    case status of
97      Good ->
98        if newCol > indent && newCol > 1
99        then
100
101          let
102            !newState = P.State src newPos end indent newRow newCol
103          in
104          cok () newState
105
106        else
107          cerr row col toIndentError
108
109      HasTab               -> cerr newRow newCol (toSpaceError E.HasTab)
110      EndlessMultiComment  -> cerr newRow newCol (toSpaceError E.EndlessMultiComment)
111
112
113
114-- EAT SPACES
115
116
117data Status
118  = Good
119  | HasTab
120  | EndlessMultiComment
121
122
123eatSpaces :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
124eatSpaces pos end row col =
125  if pos >= end then
126    (# Good, pos, row, col #)
127
128  else
129    case P.unsafeIndex pos of
130      0x20 {-   -} ->
131        eatSpaces (plusPtr pos 1) end row (col + 1)
132
133      0x0A {- \n -} ->
134        eatSpaces (plusPtr pos 1) end (row + 1) 1
135
136      0x7B {- { -} ->
137        eatMultiComment pos end row col
138
139      0x2D {- - -} ->
140        let !pos1 = plusPtr pos 1 in
141        if pos1 < end && P.unsafeIndex pos1 == 0x2D {- - -} then
142          eatLineComment (plusPtr pos 2) end row (col + 2)
143        else
144          (# Good, pos, row, col #)
145
146      0x0D {- \r -} ->
147        eatSpaces (plusPtr pos 1) end row col
148
149      0x09 {- \t -} ->
150        (# HasTab, pos, row, col #)
151
152      _ ->
153        (# Good, pos, row, col #)
154
155
156
157-- LINE COMMENTS
158
159
160eatLineComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
161eatLineComment pos end row col =
162  if pos >= end then
163    (# Good, pos, row, col #)
164
165  else
166    let !word = P.unsafeIndex pos in
167    if word == 0x0A {- \n -} then
168      eatSpaces (plusPtr pos 1) end (row + 1) 1
169    else
170      let !newPos = plusPtr pos (P.getCharWidth word) in
171      eatLineComment newPos end row (col + 1)
172
173
174
175-- MULTI COMMENTS
176
177
178eatMultiComment :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> (# Status, Ptr Word8, Row, Col #)
179eatMultiComment pos end row col =
180  let
181    !pos1 = plusPtr pos 1
182    !pos2 = plusPtr pos 2
183  in
184  if pos2 >= end then
185    (# Good, pos, row, col #)
186
187  else if P.unsafeIndex pos1 == 0x2D {- - -} then
188
189    if P.unsafeIndex pos2 == 0x7C {- | -} then
190      (# Good, pos, row, col #)
191    else
192      let
193        (# status, newPos, newRow, newCol #) =
194          eatMultiCommentHelp pos2 end row (col + 2) 1
195      in
196      case status of
197        MultiGood    -> eatSpaces newPos end newRow newCol
198        MultiTab     -> (# HasTab, newPos, newRow, newCol #)
199        MultiEndless -> (# EndlessMultiComment, pos, row, col #)
200
201  else
202    (# Good, pos, row, col #)
203
204
205data MultiStatus
206  = MultiGood
207  | MultiTab
208  | MultiEndless
209
210
211eatMultiCommentHelp :: Ptr Word8 -> Ptr Word8 -> Row -> Col -> Word16 -> (# MultiStatus, Ptr Word8, Row, Col #)
212eatMultiCommentHelp pos end row col openComments =
213  if pos >= end then
214    (# MultiEndless, pos, row, col #)
215
216  else
217    let !word = P.unsafeIndex pos in
218    if word == 0x0A {- \n -} then
219      eatMultiCommentHelp (plusPtr pos 1) end (row + 1) 1 openComments
220
221    else if word == 0x09 {- \t -} then
222      (# MultiTab, pos, row, col #)
223
224    else if word == 0x2D {- - -} && P.isWord (plusPtr pos 1) end 0x7D {- } -} then
225      if openComments == 1 then
226        (# MultiGood, plusPtr pos 2, row, col + 2 #)
227      else
228        eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments - 1)
229
230    else if word == 0x7B {- { -} && P.isWord (plusPtr pos 1) end 0x2D {- - -} then
231      eatMultiCommentHelp (plusPtr pos 2) end row (col + 2) (openComments + 1)
232
233    else
234      let !newPos = plusPtr pos (P.getCharWidth word) in
235      eatMultiCommentHelp newPos end row (col + 1) openComments
236
237
238
239-- DOCUMENTATION COMMENT
240
241
242docComment :: (Row -> Col -> x) -> (E.Space -> Row -> Col -> x) -> P.Parser x Src.Comment
243docComment toExpectation toSpaceError =
244  P.Parser $ \(P.State src pos end indent row col) cok _ cerr eerr ->
245    let
246      !pos3 = plusPtr pos 3
247    in
248    if pos3 <= end
249      && P.unsafeIndex (        pos  ) == 0x7B {- { -}
250      && P.unsafeIndex (plusPtr pos 1) == 0x2D {- - -}
251      && P.unsafeIndex (plusPtr pos 2) == 0x7C {- | -}
252    then
253      let
254        !col3 = col + 3
255
256        (# status, newPos, newRow, newCol #) =
257           eatMultiCommentHelp pos3 end row col3 1
258      in
259      case status of
260        MultiGood ->
261          let
262            !off = minusPtr pos3 (unsafeForeignPtrToPtr src)
263            !len = minusPtr newPos pos3 - 2
264            !snippet = P.Snippet src off len row col3
265            !comment = Src.Comment snippet
266            !newState = P.State src newPos end indent newRow newCol
267          in
268          cok comment newState
269
270        MultiTab -> cerr newRow newCol (toSpaceError E.HasTab)
271        MultiEndless -> cerr row col (toSpaceError E.EndlessMultiComment)
272    else
273      eerr row col toExpectation
274