git.iko.soy/elk
on c19392f help sign in
elk/src/Parse/Primitives.hs
224 lines 5.0 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 , getContext, 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 (A.Located E.Error) a
35run parser bytes =
36 runAt 1 1 parser bytes
39runAt :: Int -> Int -> Parser a -> B.ByteString -> Either (A.Located 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 (A.A overallRegion (E.Parse 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.BadOp _ ((_, start) : _) ->
59 mkError (R.Region start pos) (Just (R.Region pos pos))
61 E.Theories ((_, start) : _) _ ->
62 mkError (R.Region start pos) (Just (R.Region pos pos))
64 _ ->
65 mkError (R.Region pos pos) Nothing
69-- RESULT
72data Result a
73 = Ok a State E.ParseError
74 | Err E.ParseError
78-- COMBINATORS
81try :: Parser a -> Parser a
82try (Parser parser) =
83 Parser $ \state cok _ eok eerr ->
84 parser state cok eerr eok eerr
87deadend :: [E.Theory] -> Parser a
88deadend thrys =
89 Parser $ \(State _ _ _ _ row col ctx) _ _ _ eerr ->
90 eerr (E.ParseError row col (E.Theories ctx thrys))
93hint :: E.Next -> Parser a -> Parser a
94hint next (Parser parser) =
95 Parser $ \state@(State _ _ _ _ row col ctx) cok cerr eok eerr ->
96 let
97 eok' x s _ =
98 eok x s (expect row col ctx (E.Expecting next))
100 eerr' _ =
101 eerr (expect row col ctx (E.Expecting next))
102 in
103 parser state cok cerr eok' eerr'
106endOfFile :: Parser ()
107endOfFile =
108 Parser $ \state@(State _ offset terminal _ _ _ _) _ _ eok eerr ->
109 if offset < terminal then
110 eerr noError
111 else
112 eok () state noError
116-- STATE
119{-# INLINE getPosition #-}
120getPosition :: Parser R.Position
121getPosition =
122 Parser $ \state@(State _ _ _ _ row col _) _ _ eok _ ->
123 eok (R.Position row col) state noError
126getIndent :: Parser Int
127getIndent =
128 Parser $ \state@(State _ _ _ indent _ _ _) _ _ eok _ ->
129 eok indent state noError
132getCol :: Parser Int
133getCol =
134 Parser $ \state@(State _ _ _ _ _ col _) _ _ eok _ ->
135 eok col state noError
138getContext :: Parser E.ContextStack
139getContext =
140 Parser $ \state@(State _ _ _ _ _ _ ctx) _ _ eok _ ->
141 eok ctx state noError
144pushContext :: R.Position -> E.Context -> Parser ()
145pushContext pos ctx =
146 Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ ->
147 eok () (state { _context = (ctx, pos) : context }) noError
150popContext :: a -> Parser a
151popContext value =
152 Parser $ \state@(State _ _ _ _ _ _ context) _ _ eok _ ->
153 eok value (state { _context = tail context }) noError
156setIndent :: Int -> Parser ()
157setIndent indent =
158 Parser $ \state _ _ eok _ ->
159 eok () (state { _indent = indent }) noError
163-- SPACE PARSER
166type SParser a =
167 Parser (a, R.Position, W.SPos)
171-- LOCATION
174addLocation :: Parser a -> Parser (A.Located a)
175addLocation parser =
176 do start <- getPosition
177 value <- parser
178 end <- getPosition
179 return (A.at start end value)
182inContext :: R.Position -> E.Context -> Parser a -> Parser a
183inContext pos ctx parser =
184 do pushContext pos ctx
185 a <- parser
186 popContext a
189-- WHITESPACE VARIATIONS
192spaces :: Parser ()
193spaces =
194 checkSpace =<< W.whitespace
197noSpace :: R.Position -> W.SPos -> Parser ()
198noSpace pos (W.SPos spos) =
199 if pos == spos
200 then return ()
201 else deadend []
204checkSpace :: W.SPos -> Parser ()
205checkSpace (W.SPos (R.Position _ col)) =
206 do indent <- getIndent
207 if col > indent && col > 1
208 then return ()
209 else deadend [E.BadSpace]
212checkAligned :: W.SPos -> Parser ()
213checkAligned (W.SPos (R.Position _ col)) =
214 do indent <- getIndent
215 if col == indent
216 then return ()
217 else deadend [E.BadSpace]
220checkFreshLine :: W.SPos -> Parser ()
221checkFreshLine (W.SPos (R.Position _ col)) =
222 if col == 1
223 then return ()
224 else deadend [E.BadSpace]