2012-12-02 04:42:28 +00:00
|
|
|
module Parse.Expr (def,term) where
|
2012-06-11 13:11:15 +00:00
|
|
|
|
|
|
|
import Ast
|
2013-05-29 23:20:38 +00:00
|
|
|
import Located
|
2012-06-11 13:11:15 +00:00
|
|
|
import Control.Applicative ((<$>), (<*>))
|
|
|
|
import Control.Monad
|
|
|
|
import Data.Char (isSymbol, isDigit)
|
|
|
|
import Data.List (foldl')
|
|
|
|
import Text.Parsec hiding (newline,spaces)
|
2012-11-25 04:49:56 +00:00
|
|
|
import Text.Parsec.Indent
|
2012-09-02 05:26:35 +00:00
|
|
|
import qualified Text.Pandoc as Pan
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2012-11-23 04:15:59 +00:00
|
|
|
import Parse.Library
|
|
|
|
import Parse.Patterns
|
|
|
|
import Parse.Binops
|
2013-06-03 07:44:45 +00:00
|
|
|
import Parse.Types
|
2012-06-11 13:11:15 +00:00
|
|
|
|
|
|
|
import Guid
|
2012-11-23 04:30:37 +00:00
|
|
|
import Types.Types (Type (VarT), Scheme (Forall))
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2012-09-02 05:26:35 +00:00
|
|
|
import System.IO.Unsafe
|
|
|
|
|
2012-06-11 13:11:15 +00:00
|
|
|
|
|
|
|
-------- Basic Terms --------
|
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
numTerm :: IParser Expr
|
2012-07-19 11:47:53 +00:00
|
|
|
numTerm = toExpr <$> (preNum <?> "number")
|
|
|
|
where toExpr n | '.' `elem` n = FloatNum (read n)
|
|
|
|
| otherwise = IntNum (read n)
|
|
|
|
preNum = (++) <$> many1 digit <*> option "" postNum
|
|
|
|
postNum = do try $ lookAhead (string "." >> digit)
|
|
|
|
string "."
|
|
|
|
('.':) <$> many1 digit
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
strTerm :: IParser Expr
|
2012-06-11 13:11:15 +00:00
|
|
|
strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $
|
|
|
|
backslashed <|> satisfy (/='"')
|
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
varTerm :: IParser Expr
|
2012-06-11 13:11:15 +00:00
|
|
|
varTerm = toVar <$> var <?> "variable"
|
|
|
|
|
|
|
|
toVar v = case v of "True" -> Boolean True
|
|
|
|
"False" -> Boolean False
|
|
|
|
_ -> Var v
|
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
chrTerm :: IParser Expr
|
2012-06-11 13:11:15 +00:00
|
|
|
chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
|
|
|
|
<?> "character"
|
|
|
|
|
2012-12-25 08:39:18 +00:00
|
|
|
accessor :: IParser Expr
|
|
|
|
accessor = do
|
|
|
|
start <- getPosition
|
2012-12-26 22:07:09 +00:00
|
|
|
lbl <- try (string "." >> rLabel)
|
|
|
|
end <- getPosition
|
2013-05-29 23:20:38 +00:00
|
|
|
let loc e = addLoc ("." ++ lbl) (pos start end e)
|
|
|
|
return (Lambda "_" (loc $ Access (loc $ Var "_") lbl))
|
2012-12-25 08:39:18 +00:00
|
|
|
|
2012-06-11 13:11:15 +00:00
|
|
|
|
|
|
|
-------- Complex Terms --------
|
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
listTerm :: IParser Expr
|
2012-12-25 08:39:18 +00:00
|
|
|
listTerm =
|
|
|
|
(do { try $ string "[markdown|"
|
|
|
|
; md <- filter (/='\r') <$> manyTill anyChar (try $ string "|]")
|
2013-01-25 10:31:41 +00:00
|
|
|
; return . Markdown $ Pan.readMarkdown Pan.def md })
|
2012-12-25 08:39:18 +00:00
|
|
|
<|> (braces $ choice
|
|
|
|
[ try $ do { lo <- expr; whitespace; string ".." ; whitespace
|
|
|
|
; Range lo <$> expr }
|
2013-05-29 23:20:38 +00:00
|
|
|
, do (L _ _ e) <- list <$> commaSep expr
|
2012-12-25 08:39:18 +00:00
|
|
|
return e
|
|
|
|
])
|
|
|
|
|
|
|
|
parensTerm :: IParser CExpr
|
2012-06-11 13:11:15 +00:00
|
|
|
parensTerm = parens $ choice
|
2012-12-25 08:39:18 +00:00
|
|
|
[ do start <- getPosition
|
|
|
|
op <- try anyOp
|
|
|
|
end <- getPosition
|
2013-05-29 23:20:38 +00:00
|
|
|
let loc = pos start end
|
|
|
|
return . loc . Lambda "x" . loc . Lambda "y" . loc $
|
|
|
|
Binop op (loc $ Var "x") (loc $ Var "y")
|
2012-12-25 08:39:18 +00:00
|
|
|
, do start <- getPosition
|
|
|
|
let comma = char ',' <?> "comma ','"
|
2012-10-07 20:20:28 +00:00
|
|
|
commas <- comma >> many (whitespace >> comma)
|
2012-12-25 08:39:18 +00:00
|
|
|
end <- getPosition
|
2012-10-07 20:20:28 +00:00
|
|
|
let vars = map (('v':) . show) [ 0 .. length commas + 1 ]
|
2013-05-29 23:20:38 +00:00
|
|
|
loc = pos start end
|
|
|
|
return $ foldr (\x e -> loc $ Lambda x e)
|
|
|
|
(loc . tuple $ map (loc . Var) vars) vars
|
2012-12-25 08:39:18 +00:00
|
|
|
, do start <- getPosition
|
|
|
|
es <- commaSep expr
|
|
|
|
end <- getPosition
|
|
|
|
return $ case es of [e] -> e
|
|
|
|
_ -> pos start end (tuple es)
|
2012-06-11 13:11:15 +00:00
|
|
|
]
|
|
|
|
|
2012-12-26 22:07:09 +00:00
|
|
|
recordTerm :: IParser CExpr
|
2013-05-29 23:20:38 +00:00
|
|
|
recordTerm = brackets $ choice [ misc, addLocation record ]
|
2012-12-25 08:39:18 +00:00
|
|
|
where field = do
|
2012-12-26 22:07:09 +00:00
|
|
|
fDefs <- (:) <$> (PVar <$> rLabel) <*> spacePrefix patternTerm
|
2012-12-25 09:45:02 +00:00
|
|
|
whitespace
|
|
|
|
e <- string "=" >> whitespace >> expr
|
2013-02-09 21:02:24 +00:00
|
|
|
n <- sourceLine <$> getPosition
|
|
|
|
runAt (1000 * n) $ flattenPatterns fDefs e
|
2012-12-25 08:39:18 +00:00
|
|
|
extract [ FnDef f args exp ] = return (f,args,exp)
|
|
|
|
extract _ = fail "Improperly formed record field."
|
2012-12-25 09:45:02 +00:00
|
|
|
record = Record <$> (mapM extract =<< commaSep field)
|
2012-12-26 22:07:09 +00:00
|
|
|
change = do
|
|
|
|
lbl <- rLabel
|
2012-12-25 09:45:02 +00:00
|
|
|
whitespace >> string "<-" >> whitespace
|
2012-12-26 22:07:09 +00:00
|
|
|
(,) lbl <$> expr
|
2013-05-29 23:20:38 +00:00
|
|
|
remove r = addLocation (string "-" >> whitespace >> Remove r <$> rLabel)
|
|
|
|
insert r = addLocation $ do
|
2012-12-26 22:07:09 +00:00
|
|
|
string "|" >> whitespace
|
|
|
|
Insert r <$> rLabel <*>
|
|
|
|
(whitespace >> string "=" >> whitespace >> expr)
|
2013-05-29 23:20:38 +00:00
|
|
|
modify r = addLocation
|
2012-12-26 22:07:09 +00:00
|
|
|
(string "|" >> whitespace >> Modify r <$> commaSep1 change)
|
|
|
|
misc = try $ do
|
2013-05-29 23:20:38 +00:00
|
|
|
record <- addLocation (Var <$> rLabel)
|
2012-12-26 22:07:09 +00:00
|
|
|
whitespace
|
|
|
|
opt <- optionMaybe (remove record)
|
|
|
|
whitespace
|
|
|
|
case opt of
|
|
|
|
Just e -> try (insert e) <|> return e
|
|
|
|
Nothing -> try (insert record) <|> try (modify record)
|
|
|
|
|
2012-12-25 08:39:18 +00:00
|
|
|
|
|
|
|
term :: IParser CExpr
|
2013-05-29 23:20:38 +00:00
|
|
|
term = addLocation (choice [ numTerm, strTerm, chrTerm, listTerm, accessor ])
|
|
|
|
<|> accessible (addLocation varTerm <|> parensTerm <|> recordTerm)
|
2012-12-25 08:39:18 +00:00
|
|
|
<?> "basic term (4, x, 'c', etc.)"
|
2012-06-11 13:11:15 +00:00
|
|
|
|
|
|
|
-------- Applications --------
|
|
|
|
|
2012-12-25 08:39:18 +00:00
|
|
|
appExpr :: IParser CExpr
|
2012-06-11 13:11:15 +00:00
|
|
|
appExpr = do
|
|
|
|
tlist <- spaceSep1 term
|
|
|
|
return $ case tlist of
|
|
|
|
t:[] -> t
|
2012-12-25 08:39:18 +00:00
|
|
|
t:ts -> foldl' (\f x -> epos f x $ App f x) t ts
|
2012-06-11 13:11:15 +00:00
|
|
|
|
|
|
|
-------- Normal Expressions --------
|
|
|
|
|
2012-12-25 08:39:18 +00:00
|
|
|
binaryExpr :: IParser CExpr
|
2013-06-05 21:22:11 +00:00
|
|
|
binaryExpr = binops [] appExpr anyOp
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
ifExpr :: IParser Expr
|
2012-12-25 08:39:18 +00:00
|
|
|
ifExpr = reserved "if" >> whitespace >> (normal <|> multiIf)
|
|
|
|
where normal = do e1 <- expr ; whitespace
|
|
|
|
reserved "then" ; whitespace ; e2 <- expr
|
|
|
|
whitespace <?> "an 'else' branch"
|
|
|
|
reserved "else" <?> "an 'else' branch" ; whitespace
|
|
|
|
If e1 e2 <$> expr
|
|
|
|
multiIf = (MultiIf <$> spaceSep1 iff)
|
|
|
|
where iff = do string "|" ; whitespace
|
|
|
|
b <- expr ; whitespace ; string "->" ; whitespace
|
|
|
|
(,) b <$> expr
|
|
|
|
|
|
|
|
lambdaExpr :: IParser CExpr
|
2012-06-11 13:11:15 +00:00
|
|
|
lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
|
|
|
|
whitespace
|
2012-07-21 23:48:51 +00:00
|
|
|
pats <- spaceSep1 patternTerm
|
2012-06-11 13:11:15 +00:00
|
|
|
whitespace ; arrow ; whitespace
|
|
|
|
e <- expr
|
2012-12-26 22:07:09 +00:00
|
|
|
return . run $ makeLambda pats e
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
defSet :: IParser [Def]
|
2013-06-03 07:44:45 +00:00
|
|
|
defSet = concat <$> block (do d <- anyDef ; whitespace ; return d)
|
2012-11-25 04:49:56 +00:00
|
|
|
|
|
|
|
letExpr :: IParser Expr
|
2012-10-08 03:34:04 +00:00
|
|
|
letExpr = do
|
|
|
|
reserved "let" ; whitespace
|
|
|
|
defs <- defSet
|
|
|
|
whitespace ; reserved "in" ; whitespace
|
|
|
|
Let defs <$> expr
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
caseExpr :: IParser Expr
|
2012-06-11 13:11:15 +00:00
|
|
|
caseExpr = do
|
|
|
|
reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
|
2012-11-25 04:49:56 +00:00
|
|
|
Case e <$> (with <|> without)
|
2012-06-11 13:11:15 +00:00
|
|
|
where case_ = do p <- patternExpr; whitespace; arrow; whitespace
|
|
|
|
(,) p <$> expr
|
2012-11-25 04:49:56 +00:00
|
|
|
with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
|
|
|
|
without = block (do c <- case_ ; whitespace ; return c)
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2013-05-29 23:20:38 +00:00
|
|
|
expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
|
2012-12-25 08:39:18 +00:00
|
|
|
<|> lambdaExpr
|
|
|
|
<|> binaryExpr
|
|
|
|
<?> "an expression"
|
2012-06-12 06:28:45 +00:00
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
funcDef = try (do p1 <- try patternTerm ; infics p1 <|> func p1)
|
|
|
|
<|> ((:[]) <$> patternExpr)
|
|
|
|
<?> "the definition of a variable (x = ...)"
|
2012-11-23 03:48:54 +00:00
|
|
|
where func p@(PVar v) = (p:) <$> spacePrefix patternTerm
|
|
|
|
func p = do try (lookAhead (whitespace >> string "="))
|
|
|
|
return [p]
|
|
|
|
infics p1 = do
|
|
|
|
o:p <- try (whitespace >> anyOp)
|
|
|
|
p2 <- (whitespace >> patternTerm)
|
|
|
|
return $ if o == '`' then [ PVar $ takeWhile (/='`') p, p1, p2 ]
|
|
|
|
else [ PVar (o:p), p1, p2 ]
|
|
|
|
|
2012-11-25 04:49:56 +00:00
|
|
|
assignExpr :: IParser [Def]
|
|
|
|
assignExpr = withPos $ do
|
|
|
|
fDefs <- funcDef
|
|
|
|
whitespace
|
2012-12-25 08:39:18 +00:00
|
|
|
e <- string "=" >> whitespace >> expr
|
2013-02-09 21:02:24 +00:00
|
|
|
n <- sourceLine <$> getPosition
|
|
|
|
runAt (1000 * n) $ flattenPatterns fDefs e
|
2012-11-23 03:48:54 +00:00
|
|
|
|
2013-06-03 07:44:45 +00:00
|
|
|
anyDef =
|
|
|
|
((\d -> [d]) <$> typeAnnotation) <|>
|
|
|
|
assignExpr
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2013-06-03 07:44:45 +00:00
|
|
|
def = map Definition <$> anyDef
|
2012-06-11 13:11:15 +00:00
|
|
|
|
2012-06-12 06:28:45 +00:00
|
|
|
parseDef str =
|
2012-11-25 04:49:56 +00:00
|
|
|
case iParse def "" str of
|
2012-06-11 13:11:15 +00:00
|
|
|
Right result -> Right result
|
|
|
|
Left err -> Left $ "Parse error at " ++ show err
|