git.iko.soy/elk
on 00a3069 help sign in
elk/src/Parse/Primitives.hs
221 lines 4.9 kB history raw
1{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Parse.Primitives
4 ( I.Parser
5 , I.oneOf
6 , run, runAt
7 , try, deadend, hint, endOfFile
8 , getPosition, getCol
9 , pushContext, popContext
10 , getIndent, setIndent
11 , W.SPos
12 , SParser
13 , addLocation, inContext
14 , spaces, noSpace, checkSpace, checkAligned, checkFreshLine
15 )
16 where
19import Prelude hiding (length)
20import qualified Data.ByteString.Internal as B
22import Parse.Primitives.Internals (Parser(..), State(..), expect, noError)
23import qualified Parse.Primitives.Internals as I
24import qualified Parse.Primitives.Whitespace as W
25import qualified Reporting.Annotation as A
26import qualified Reporting.Error.Syntax as E
27import qualified Reporting.Region as R
31-- RUN
34run :: Parser a -> B.ByteString -> Either E.Error a
35run parser bytes =
36 runAt 1 1 parser bytes
39runAt :: Int -> Int -> Parser a -> B.ByteString -> Either E.Error a
40runAt startRow startColumn (Parser parser) (B.PS fp offset length) =
41 case parser (State fp offset (offset + length) 0 startRow startColumn []) Ok Err Ok Err of
42 Ok value _ _ ->
43 Right value
45 Err (E.ParseError row col problem) ->
46 let
47 pos = R.Position row col
48 mkError overallRegion subRegion =
49 Left (E.Parse overallRegion subRegion problem)
50 in
51 case problem of
52 E.BadChar endCol ->
53 mkError (R.Region pos (R.Position row endCol)) Nothing
55 E.BadEscape width _ ->
56 mkError (R.Region pos (R.Position row (col + width))) Nothing
58 E.BadUnderscore badCol ->
59 mkError (R.Region pos (R.Position row badCol)) Nothing
61 E.BadOp _ ((_, start) : _) ->
62 mkError (R.Region start pos) (Just (R.Region pos pos))
64 E.Theories ((_, start) : _) _ ->
65 mkError (R.Region start pos) (Just (R.Region pos pos))
67 _ ->
68 mkError (R.Region pos pos) Nothing
72-- RESULT
75data Result a
76 = Ok a State E.ParseError
77 | Err E.ParseError
81-- COMBINATORS
84try :: Parser a -> Parser a
85try (Parser parser) =
86 Parser $ \state cok _ eok eerr ->
87 parser state cok eerr eok eerr
90deadend :: [E.Theory] -> Parser a
91deadend thrys =
92 Parser $ \(State _ _ _ _ row col ctx) _ _ _ eerr ->
93 eerr (E.ParseError row col (E.Theories ctx thrys))
96hint :: E.Next -> Parser a -> Parser a
97hint next (Parser parser) =
98 Parser $ \state@(State _ _ _ _ row col ctx) cok cerr eok eerr ->
99 let
100 eok' x s _ =
101 eok x s (expect row col ctx (E.Expecting next))
103 eerr' _ =
104 eerr (expect row col ctx (E.Expecting next))
105 in
106 parser state cok cerr eok' eerr'
109endOfFile :: Parser ()
110endOfFile =
111 Parser $ \state@(State _ offset terminal _ _ _ _) _ _ eok eerr ->
112 if offset < terminal then
113 eerr noError
114 else
115 eok () state noError
119-- STATE
122{-# INLINE getPosition #-}
123getPosition :: Parser R.Position
124getPosition =
125 Parser $ \state@(State _ _ _ _ row col _) _ _ eok _ ->
126 eok (R.Position row col) state noError
129getIndent :: Parser Int
130getIndent =
131 Parser $ \state@(State _ _ _ indent _ _ _) _ _ eok _ ->
132 eok indent state noError
135getCol :: Parser Int
136getCol =
137 Parser $ \state@(State _ _ _ _ _ col _) _ _ eok _ ->
138 eok col state noError
141pushContext :: R.Position -> E.Context -> Parser ()
142pushContext pos ctx =
143 Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ ->
144 eok () (state { _context = (ctx, pos) : context }) noError
147popContext :: a -> Parser a
148popContext value =
149 Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ ->
150 eok value (state { _context = tail context }) noError
153setIndent :: Int -> Parser ()
154setIndent indent =
155 Parser $ \state _ _ eok _ ->
156 eok () (state { _indent = indent }) noError
160-- SPACE PARSER
163type SParser a =
164 Parser (a, R.Position, W.SPos)
168-- LOCATION
171addLocation :: Parser a -> Parser (A.Located a)
172addLocation parser =
173 do start <- getPosition
174 value <- parser
175 end <- getPosition
176 return (A.at start end value)
179inContext :: R.Position -> E.Context -> Parser a -> Parser a
180inContext pos ctx parser =
181 do pushContext pos ctx
182 a <- parser
183 popContext a
186-- WHITESPACE VARIATIONS
189spaces :: Parser ()
190spaces =
191 checkSpace =<< W.whitespace
194noSpace :: R.Position -> W.SPos -> Parser ()
195noSpace pos (W.SPos spos) =
196 if pos == spos
197 then return ()
198 else deadend []
201checkSpace :: W.SPos -> Parser ()
202checkSpace (W.SPos (R.Position _ col)) =
203 do indent <- getIndent
204 if col > indent && col > 1
205 then return ()
206 else deadend [E.BadSpace]
209checkAligned :: W.SPos -> Parser ()
210checkAligned (W.SPos (R.Position _ col)) =
211 do indent <- getIndent
212 if col == indent
213 then return ()
214 else deadend [E.BadSpace]
217checkFreshLine :: W.SPos -> Parser ()
218checkFreshLine (W.SPos (R.Position _ col)) =
219 if col == 1
220 then return ()
221 else deadend [E.BadSpace]