git.iko.soy/elk
on 294fdfd help sign in
elk/compiler/Parse/Library.hs
185 lines 5.5 kB history raw
2module Parse.Library where
4import Ast
5import Context
6import Control.Applicative ((<$>),(<*>))
7import Control.Monad
8import Control.Monad.State
9import Data.Char (isSymbol,isUpper)
10import Rename (deprime)
11import Text.Parsec hiding (newline,spaces,State)
12import Text.Parsec.Indent
14reserveds = [ "if", "then", "else"
15 , "case", "of"
16 , "let", "in"
17 , "data", "type"
18 , "module", "where"
19 , "import", "as", "hiding"
20 , "export", "foreign" ]
22expecting = flip (<?>)
24type IParser a = ParsecT String () (State SourcePos) a
26iParse :: IParser a -> SourceName -> String -> Either ParseError a
27iParse aParser source_name input =
28 runIndent source_name $ runParserT aParser () source_name input
30backslashed :: IParser Char
31backslashed = do { char '\\'; c <- anyChar
32 ; return . read $ ['\'','\\',c,'\''] }
34var :: IParser String
35var = makeVar (letter <|> char '_' <?> "variable")
37lowVar :: IParser String
38lowVar = makeVar (lower <?> "lower case variable")
39capVar :: IParser String
40capVar = makeVar (upper <?> "upper case variable")
42rLabel :: IParser String
43rLabel = deprime <$> lowVar
45innerVarChar :: IParser Char
46innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
48makeVar :: IParser Char -> IParser String
49makeVar p = do v <- (:) <$> p <*> many innerVarChar
50 guard (v `notElem` reserveds)
51 return v
53reserved :: String -> IParser String
54reserved word =
55 try (string word >> notFollowedBy innerVarChar) >> return word
56 <?> "reserved word '" ++ word ++ "'"
58anyOp :: IParser String
59anyOp = betwixt '`' '`' var <|> symOp <?> "infix operator (e.g. +, *, ||)"
61isOp c = isSymbol c || elem c "+-/*=.$<>:&|^?%#@~!"
63symOp :: IParser String
64symOp = do op <- many1 (satisfy isOp)
65 guard (op `notElem` [ "=", "..", "->", "--", "|", "\8594", ":" ])
66 case op of
67 "." -> notFollowedBy lower >> return op
68 "\8728" -> return "."
69 _ -> return op
71arrow :: IParser String
72arrow = string "->" <|> string "\8594" <?> "arrow (->)"
74hasType :: IParser String
75hasType = string ":" <?> "':' (a type annotation)'"
78commitIf check p = commit <|> try p
79 where commit = do (try $ lookAhead check) >> p
81spaceySepBy1 :: IParser b -> IParser a -> IParser [a]
82spaceySepBy1 sep p = do
83 a <- p
84 (a:) <$> many (commitIf (whitespace >> sep) (whitespace >> sep >> whitespace >> p))
87commaSep1 :: IParser a -> IParser [a]
88commaSep1 = spaceySepBy1 (char ',' <?> "comma ','")
90commaSep :: IParser a -> IParser [a]
91commaSep = option [] . commaSep1
93semiSep1 :: IParser a -> IParser [a]
94semiSep1 = spaceySepBy1 (char ';' <?> "semicolon ';'")
96pipeSep1 :: IParser a -> IParser [a]
97pipeSep1 = spaceySepBy1 (char '|' <?> "type divider '|'")
99consSep1 :: IParser a -> IParser [a]
100consSep1 = spaceySepBy1 (string "::" <?> "cons operator '::'")
102dotSep1 :: IParser a -> IParser [a]
103dotSep1 p = (:) <$> p <*> many (try (char '.') >> p)
105spaceSep1 :: IParser a -> IParser [a]
106spaceSep1 p = (:) <$> p <*> spacePrefix p
108spacePrefix p = many (try (whitespace >> indented >> p))
110followedBy a b = do x <- a ; b ; return x
112betwixt a b c = do char a ; out <- c
113 char b <?> "closing '" ++ [b] ++ "'" ; return out
115surround a z name p = do
116 char a ; whitespace ; v <- p ; whitespace
117 char z <?> unwords ["closing", name, show z]
118 return v
120braces :: IParser a -> IParser a
121braces = surround '[' ']' "brace"
123parens :: IParser a -> IParser a
124parens = surround '(' ')' "paren"
126brackets :: IParser a -> IParser a
127brackets = surround '{' '}' "bracket"
129addContext :: IParser Expr -> IParser CExpr
130addContext expr = do
131 start <- getPosition
132 e <- expr
133 end <- getPosition
134 return (pos start end e)
136accessible :: IParser CExpr -> IParser CExpr
137accessible expr = do
138 start <- getPosition
139 ce@(C s t e) <- expr
140 let rest f = do
141 let dot = char '.' >> notFollowedBy (char '.')
142 access <- optionMaybe (try dot <?> "field access (e.g. List.map)")
143 case access of
144 Nothing -> return ce
145 Just _ -> accessible $ do
146 v <- var <?> "field access (e.g. List.map)"
147 end <- getPosition
148 return (pos start end (f v))
149 case e of Var (c:cs) | isUpper c -> rest (\v -> Var (c:cs ++ '.':v))
150 | otherwise -> rest (Access ce)
151 _ -> rest (Access ce)
154spaces :: IParser String
155spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"
157forcedWS :: IParser [String]
158forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
159 where nl_space = try $ many1 newline >> spaces
161whitespace :: IParser ()
162whitespace = optional forcedWS <?> ""
164freshLine :: IParser [[String]]
165freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
166 where space_nl = try $ spaces >> many1 newline
168newline :: IParser String
169newline = simpleNewline <|> lineComment <?> ""
171simpleNewline :: IParser String
172simpleNewline = try (string "\r\n") <|> string "\n"
174lineComment :: IParser String
175lineComment = do try (string "--")
176 manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
178multiComment :: IParser String
179multiComment = do { try (string "{-"); closeComment }
181closeComment :: IParser String
182closeComment = manyTill anyChar . choice $
183 [ try (string "-}") <?> "close comment"
184 , do { try $ string "{-"; closeComment; closeComment }
185 ]