1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
module Parser where
import Control.Applicative
import Data.Char (isSpace)
import Control.Monad.Chronicle
import Control.Monad.Reader
import Control.Monad.State.Strict
import Data.Foldable (asum)
import Data.These
import AST
-- Positions are zero-based in both dimensions
data PS = PS
{ psRefCol :: Int
, psLine :: Int
, psCol :: Int
, psRest :: String }
deriving (Show)
data Context = Context { ctxFile :: FilePath }
deriving (Show)
type Parser = ReaderT Context (ChronicleT [ErrMsg] (State PS))
-- Positions are zero-based in both dimensions
data ErrMsg = ErrMsg { errFile :: FilePath
, errLine :: Int
, errCol :: Int
, errMsg :: String }
deriving (Show)
printErrMsg :: ErrMsg -> String
printErrMsg (ErrMsg fp y x s) = fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s
parse :: FilePath -> String -> These [ErrMsg] (Program ())
parse fp source =
flip evalState (PS 0 0 0 source)
. runChronicleT
. flip runReaderT (Context fp)
$ pProgram
pProgram :: Parser (Program ())
pProgram = do
prog <- Program <$> many pFunDef
skipWhiteComment
assertEOF Error
return prog
pFunDef :: Parser (FunDef ())
pFunDef = _
data Fatality = Error | Fatal
deriving (Show)
raise :: Fatality -> String -> Parser ()
raise fat msg = do
fp <- asks ctxFile
ps <- get
let fun = case fat of
Error -> dictate . pure
Fatal -> confess . pure
fun (ErrMsg fp (psLine ps) (psCol ps) msg)
assertEOF :: Fatality -> Parser ()
assertEOF fat = gets psRest >>= \case
[] -> return ()
_ -> raise fat "Unexpected stuff"
data ReadResult a = Token a | Truncated a
deriving (Show, Functor)
readInline :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String)
readInline f s0 = do
ps0 <- get
when (psCol ps0 <= psRefCol ps0) $
raise Fatal "Expected stuff, but found end of indented expression"
let loop :: (s -> Char -> Maybe s) -> s -> Parser (ReadResult String)
loop f' st = do
ps <- get
case psRest ps of
c : cs | Just st' <- f' st c -> do
put (ps { psCol = psCol ps + 1, psRest = cs })
fmap (c :) <$> loop f' st'
| otherwise -> return (Token "")
[] -> return (Truncated "")
loop f s0
skipWhiteComment :: Parser ()
skipWhiteComment = do
inlineWhite
_ <- many (inlineComment >> inlineWhite)
_ <- optional lineComment
(consumeNewline >> skipWhiteComment) <|> return ()
where
inlineWhite :: Parser ()
inlineWhite = readWhileInline isSpace
inlineComment :: Parser ()
inlineComment = do
string "{-"
let loop = do
readWhileInline (`notElem` "{-")
asum [string "-}"
,inlineComment >> loop
,consumeNewline >> loop]
loop
lineComment :: Parser ()
lineComment = string "--" >> readWhileInline (const True)
readWhileInline :: (Char -> Bool) -> Parser ()
readWhileInline p = do
(taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest
modify (\ps -> ps { psCol = psCol ps + length taken
, psRest = rest })
consumeNewline :: Parser ()
consumeNewline = gets psRest >>= \case
'\n' : rest -> modify (\ps -> ps { psLine = psLine ps + 1
, psCol = 0
, psRest = rest })
_ -> empty
string :: String -> Parser ()
string s | any (== '\n') s = error "Newline in 'string' argument"
string s = do
ps <- get
if take (length s) (psRest ps) == s
then put (ps { psCol = psCol ps + length s
, psRest = drop (length s) (psRest ps) })
else empty
|
