@@ -4,8 +4,10 @@ module Parse.Library where
44import Ast
55import Control.Applicative ((<$>),(<*>))
66import Control.Monad
7+import Control.Monad.State
78import Data.Char (isSymbol)
8−import Text.Parsec hiding (newline,spaces)
9+import Text.Parsec hiding (newline,spaces,State)
10+import Text.Parsec.Indent
911
1012reserveds = [ "if", "then", "else"
1113 , "case", "of", "data"
@@ -16,74 +18,82 @@ reserveds = [ "if", "then", "else"
1618
1719expecting = flip (<?>)
1820
19−backslashed :: (Monad m) => ParsecT [Char] u m Char
21+type IParser a = ParsecT String () (State SourcePos) a
22+
23+iParse :: IParser a -> SourceName -> String -> Either ParseError a
24+iParse aParser source_name input =
25+ runIndent source_name $ runParserT aParser () source_name input
26+
27+backslashed :: IParser Char
2028backslashed = do { char '\\'; c <- anyChar
2129 ; return . read $ ['\'','\\',c,'\''] }
2230
23−var :: (Monad m) => ParsecT [Char] u m String
31+var :: IParser String
2432var = makeVar (letter <|> char '_' <?> "variable")
2533
26−lowVar :: (Monad m) => ParsecT [Char] u m String
34+lowVar :: IParser String
2735lowVar = makeVar (lower <?> "lower case variable")
28−capVar :: (Monad m) => ParsecT [Char] u m String
36+capVar :: IParser String
2937capVar = makeVar (upper <?> "upper case variable")
3038
31−innerVarChar :: (Monad m) => ParsecT [Char] u m Char
39+innerVarChar :: IParser Char
3240innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
3341
42+makeVar :: IParser Char -> IParser String
3443makeVar p = do v <- (:) <$> p <*> many innerVarChar
3544 guard (v `notElem` reserveds)
3645 return v
3746
47+reserved :: String -> IParser String
3848reserved word =
3949 try (string word >> notFollowedBy innerVarChar) >> return word
4050 <?> "reserved word '" ++ word ++ "'"
4151
42−anyOp :: (Monad m) => ParsecT [Char] u m String
52+anyOp :: IParser String
4353anyOp = betwixt '`' '`' var <|> symOp <?> "infix operator (e.g. +, *, ||)"
4454
4555isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
4656
47−symOp :: (Monad m) => ParsecT [Char] u m String
57+symOp :: IParser String
4858symOp = do op <- many1 (satisfy isOp)
4959 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594" ])
5060 return op
5161
52−arrow :: (Monad m) => ParsecT [Char] u m String
62+arrow :: IParser String
5363arrow = string "->" <|> string "\8594" <?> "arrow (->)"
5464
5565
5666commitIf check p = commit <|> try p
5767 where commit = do (try $ lookAhead check) >> p
5868
59−spaceySepBy1 :: (Monad m) => ParsecT [Char] u m b -> ParsecT [Char] u m a -> ParsecT [Char] u m [a]
69+spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
6070spaceySepBy1 sep p = do
6171 a <- p
6272 (a:) <$> many (commitIf (whitespace >> sep) (whitespace >> sep >> whitespace >> p))
6373
6474
65−commaSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
75+commaSep1 :: IParser a -> IParser [a]
6676commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")
6777
68−commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
78+commaSep :: IParser a -> IParser [a]
6979commaSep = option [] . commaSep1
7080
71−semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
81+semiSep1 :: IParser a -> IParser [a]
7282semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")
7383
74−pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
84+pipeSep1 :: IParser a -> IParser [a]
7585pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")
7686
77−consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
87+consSep1 :: IParser a -> IParser [a]
7888consSep1 = spaceySepBy1 (char ':' <?> "cons operator ':'")
7989
80−dotSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
90+dotSep1 :: IParser a -> IParser [a]
8191dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
8292
83−spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
93+spaceSep1 :: IParser a -> IParser [a]
8494spaceSep1 p = (:) <$> p <*> spacePrefix p
8595
86−spacePrefix p = many (commitIf (whitespace >> (char '[' <|> char '(')) (whitespace >> p))
96+spacePrefix p = many (try (whitespace >> indented >> p))
8797
8898followedBy a b = do x <- a ; b ; return x
8999
@@ -95,15 +105,16 @@ surround a z name p = do
95105 char z <?> unwords ["closing", name, show z]
96106 return v
97107
98−braces :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
108+braces :: IParser a -> IParser a
99109braces = surround '[' ']' "brace"
100110
101−parens :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
111+parens :: IParser a -> IParser a
102112parens = surround '(' ')' "paren"
103113
104−brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
114+brackets :: IParser a -> IParser a
105115brackets = surround '{' '}' "bracket"
106116
117+accessible :: IParser Expr -> IParser Expr
107118accessible expr = do
108119 e <- expr
109120 access <- optionMaybe . try $
@@ -113,34 +124,34 @@ accessible expr = do
113124 Nothing -> return e
114125
115126
116−spaces :: (Monad m) => ParsecT [Char] u m String
127+spaces :: IParser String
117128spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"
118129
119−forcedWS :: (Monad m) => ParsecT [Char] u m [String]
130+forcedWS :: IParser [String]
120131forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
121132 where nl_space = try $ many1 newline >> spaces
122133
123−whitespace :: (Monad m) => ParsecT [Char] u m ()
134+whitespace :: IParser ()
124135whitespace = optional forcedWS <?> ""
125136
126−freshLine :: (Monad m) => ParsecT [Char] u m [[String]]
137+freshLine :: IParser [[String]]
127138freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""
128139 where space_nl = try $ spaces >> many1 newline
129140
130−newline :: (Monad m) => ParsecT [Char] u m String
141+newline :: IParser String
131142newline = simpleNewline <|> lineComment <?> ""
132143
133−simpleNewline :: (Monad m) => ParsecT [Char] u m String
144+simpleNewline :: IParser String
134145simpleNewline = try (string "\r\n") <|> string "\n"
135146
136−lineComment :: (Monad m) => ParsecT [Char] u m String
147+lineComment :: IParser String
137148lineComment = do try (string "--")
138149 manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
139150
140−multiComment :: (Monad m) => ParsecT [Char] u m String
151+multiComment :: IParser String
141152multiComment = do { try (string "{-"); closeComment }
142153
143−closeComment :: (Monad m) => ParsecT [Char] u m String
154+closeComment :: IParser String
144155closeComment = manyTill anyChar . choice $
145156 [ try (string "-}") <?> "close comment"
146157 , do { try $ string "{-"; closeComment; closeComment }