42b364d · elk · git.iko.soy

elm/Elm.cabal+2−2

compare with master

unifiedsplit

@@ -39,7 +39,7 @@ Library

39 Guid,

40 Initialize,

41 Rename,

42− Binop,

42+ Binops,

43 Patterns,

44 Parser,

45 ParseLib,

@@ -72,7 +72,7 @@ Executable elm

72 Guid,

73 Initialize,

74 Rename,

75− Binop,

75+ Binops,

76 Patterns,

77 Parser,

78 ParseLib,

elm/src/CompileToJS.hs+4−1

@@ -9,9 +9,12 @@ import Data.Map (toList)

9

10import Initialize

11

12+showErr :: String -> String

13+showErr err = "text(monospace(" ++ msg ++ "))"

14+ where msg = show . concatMap (++"<br>") . lines $ err

12

15

13compile = (return . addMain . toJS) <=< initialize

16compile = (return . addMain . toJS) <=< initialize

14−compileToJS = addMain . either (\err -> "text('"++err++"')") toJS

17+compileToJS = addMain . either showErr toJS

15addMain body = "function main(){return " ++ body ++ ";}"

18addMain body = "function main(){return " ++ body ++ ";}"

16

19

17parens = ("("++) . (++")")

20parens = ("("++) . (++")")

elm/src/Compiler.hs+1−1

@@ -11,7 +11,7 @@ main = getArgs >>= parse

11

12parse :: [String] -> IO ()

13parse ("--help":_) = putStrLn usage

14−parse ("--version":_) = putStrLn "The Elm Compiler 0.1.2.1"

14+parse ("--version":_) = putStrLn "The Elm Compiler 0.2"

15parse [loc,file]

16 | "--runtime-location=" `isPrefixOf` loc =

17 produceHtml (tail $ dropWhile (/='=') loc) file

elm/src/Initialize.hs+3−10

@@ -6,23 +6,16 @@ import Control.Monad

6import Data.Char (isAlpha)

7import Data.Maybe (mapMaybe)

8import Data.Either (rights)

9−import Lexer

9+

10−import Parser (toExpr,toDefs)

10+import Parser (toDefs)

11import Rename (rename)

12

13import Unify

14import Hints

15

16−{--

17−initialize str = do

18− (expr, hints') <- toDefs =<< tokenize str

19− let expr' = rename expr

20− subs <- unify (liftM2 (++) hints hints') expr'

21− return (seq subs expr')

22−--}

23

16

24initialize str = do

17initialize str = do

25− (expr, hints') <- toDefs =<< tokenize str

18+ (expr, hints') <- toDefs str

26 let expr' = rename expr

19 let expr' = rename expr

27 subs <- unify (liftM2 (++) hints hints') expr'

20 subs <- unify (liftM2 (++) hints hints') expr'

28 let init = simp_loop expr'

21 let init = simp_loop expr'

elm/src/Parse/Binop.hs → elm/src/Parse/Binops.hsrenamed+1−1

@@ -1,4 +1,4 @@

1−module Binop (binops) where

1+module Binops (binops) where

2

3import Ast

4import Control.Monad (liftM,guard)

elm/src/Parse/ParseLib.hs+66−9

@@ -4,7 +4,7 @@ module ParseLib where

4import Ast

5import Control.Monad

6import Data.Char (isSymbol)

7−import Text.Parsec

7+import Text.Parsec hiding (newline,spaces)

8

9reserved = [ "if", "then", "else"

10 , "case", "of", "data"

@@ -12,23 +12,46 @@ reserved = [ "if", "then", "else"

12

13expecting = flip (<?>)

14

15+backslashed :: (Monad m) => ParsecT [Char] u m Char

16+backslashed = do { char '\\'; c <- anyChar

17+ ; return . read $ ['\'','\\',c,'\''] }

18+

15var :: (Monad m) => ParsecT [Char] u m String

19var :: (Monad m) => ParsecT [Char] u m String

16−var = do

20+var = makeVar $ letter <|> char '_'

17− c <- letter {-lower-} <|> char '_'

21+

22+lowVar :: (Monad m) => ParsecT [Char] u m String

23+lowVar = makeVar (lower <?> "lower case variable")

24+capVar :: (Monad m) => ParsecT [Char] u m String

25+capVar = makeVar (upper <?> "upper case variable")

26+

27+makeVar p = do

28+ c <- p

18 cs <- many $ alphaNum <|> char '_' <|> char '\''

29 cs <- many $ alphaNum <|> char '_' <|> char '\''

19 guard $ c:cs `notElem` reserved

30 guard $ c:cs `notElem` reserved

20 return $ c:cs

31 return $ c:cs

21

32

33+

22anyOp :: (Monad m) => ParsecT [Char] u m String

34anyOp :: (Monad m) => ParsecT [Char] u m String

35+anyOp = betwixt '`' '`' var <|>

23−anyOp = many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")

36+ (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")

37+ guard (op `notElem` [ "=", "..", "->" ])

38+ return op) <?> "infix operator"

24

39

25−lexeme p = do e <- p ; whitespace ; return e

40+lexeme p = do whitespace ; p

26

41

27−whitespace :: (Monad m) => ParsecT [Char] u m String

42+symbol :: (Monad m) => String -> ParsecT [Char] u m String

28−whitespace = try $ many (char ' ')

43+symbol s = whitespace >> string s

29

44

45+arrow :: (Monad m) => ParsecT [Char] u m String

46+arrow = symbol "->" <|> symbol "\8594"

47+

48+commaSep p = p `sepBy` lexeme (char ',')

49+

50+

30−betwixt a b = between (char a) (char b <?> "closing '" ++ [b] ++ "'")

51+betwixt a b c = do char a ; out <- c

31−betwixtSpcs a b = between (lexeme $ char a) (char b <?> "closing '" ++ [b] ++ "'")

52+ char b <?> "closing '" ++ [b] ++ "'" ; return out

53+betwixtSpcs a b c = do char a ; whitespace ; out <- c ; whitespace

54+ char b <?> "closing '" ++ [b] ++ "'" ; return out

32

55

33listOf p = betwixtSpcs '[' ']' $ p `sepBy` lexeme (char ',')

56listOf p = betwixtSpcs '[' ']' $ p `sepBy` lexeme (char ',')

34

57

@@ -38,3 +61,37 @@ accessible expr = do

38 case access of

61 case access of

39 Just '.' -> accessible (Access e `liftM` var)

62 Just '.' -> accessible (Access e `liftM` var)

40 Nothing -> return e

63 Nothing -> return e

64+

65+

66+spaces :: (Monad m) => ParsecT [Char] u m String

67+spaces = many1 ((multiComment <|> string " ") >> return ' ') <?> "spaces"

68+

69+forcedWS :: (Monad m) => ParsecT [Char] u m [String]

70+forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)

71+ where nl_space = try $ many1 newline >> spaces

72+

73+whitespace :: (Monad m) => ParsecT [Char] u m ()

74+whitespace = optional forcedWS <?> "whitespace"

75+

76+freshLine :: (Monad m) => ParsecT [Char] u m [[String]]

77+freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> "fresh line"

78+ where space_nl = try $ spaces >> many1 newline

79+

80+newline :: (Monad m) => ParsecT [Char] u m String

81+newline = simpleNewline <|> lineComment <?> "newline"

82+

83+simpleNewline :: (Monad m) => ParsecT [Char] u m String

84+simpleNewline = try (string "\r\n") <|> string "\n"

85+

86+lineComment :: (Monad m) => ParsecT [Char] u m String

87+lineComment = do try $ string "--"

88+ manyTill anyChar $ simpleNewline <|> (eof >> return "\n")

89+

90+multiComment :: (Monad m) => ParsecT [Char] u m String

91+multiComment = do { try $ string "{-"; closeComment }

92+

93+closeComment :: (Monad m) => ParsecT [Char] u m String

94+closeComment = manyTill anyChar . choice $

95+ [ try $ string "-}"

96+ , do { try $ string "{-"; closeComment; closeComment }

97+ ]

elm/src/Parse/ParsePatterns.hsdeleted−31

@@ -1,31 +0,0 @@

1−module ParsePatterns (patternTerm, patternExpr) where

2−

3−import Ast

4−import Combinators

5−import Data.Char (isUpper)

6−import ParserLib

7−import Tokens

8−import Control.Monad (liftM)

9−

10−patternBasic =

11− (t UNDERSCORE >> return PAnything) +|+

12− (do { x@(c:_) <- var ;

13− if isUpper c then PData x `liftM` star patternTerm

14− else return $ PVar x })

15−

16−patternTuple = do

17− t LPAREN; ps <- sepBy1 (t COMMA) patternExpr; t RPAREN

18− return $ case ps of { [p] -> p; _ -> ptuple ps }

19−

20−patternCons = do

21− p <- patternTerm

22− colon <- optional $ opParser (==":")

23− case colon of

24− Just ":" -> pcons p `liftM` patternExpr

25− Nothing -> return p

26−

27−patternList = do

28− t LBRACKET; ps <- sepBy (t COMMA) patternExpr; t RBRACKET; return (plist ps)

29−

30−patternTerm = patternTuple +|+ patternList +|+ patternBasic

31−patternExpr = patternTuple +|+ patternList +|+ patternCons

elm/src/Parse/ParseTypes.hs+35−19

@@ -1,15 +1,16 @@

1module ParseTypes where

2

3import Ast

4−import Combinators

4+import Control.Applicative ((<$>))

5+import Control.Monad (liftM)

5import Data.Char (isUpper,isLower)

6import Data.Char (isUpper,isLower)

6import Data.Maybe (fromMaybe)

7import Data.Maybe (fromMaybe)

7import Data.List (lookup)

8import Data.List (lookup)

8−import ParserLib

9+import Text.Parsec

10+

9−import Tokens

11+import ParseLib

10import Types

12import Types

11import Guid

13import Guid

12−import Control.Monad (liftM)

13

14

14data ParseType = VarPT String

15data ParseType = VarPT String

15 | LambdaPT ParseType ParseType

16 | LambdaPT ParseType ParseType

@@ -18,35 +19,50 @@ data ParseType = VarPT String

18listPT t = ADTPT "List" [t]

19listPT t = ADTPT "List" [t]

19tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts

20tuplePT ts = ADTPT ("Tuple" ++ show (length ts)) ts

20

21

22+typeVar :: (Monad m) => ParsecT [Char] u m ParseType

21−typeVar = liftM VarPT lowVar

23+typeVar = VarPT <$> lowVar <?> "type variable"

22−typeList = do t LBRACKET; te <- typeExpr; t RBRACKET; return $ listPT te

24+

23−typeTuple = do { t LPAREN; ts <- sepBy (t COMMA) typeExpr; t RPAREN

25+typeList :: (Monad m) => ParsecT [Char] u m ParseType

24− ; return $ case ts of { [t] -> t ; _ -> tuplePT ts } }

26+typeList = listPT <$> betwixtSpcs '[' ']' typeExpr

25−typeUnambiguous = typeList +|+ typeTuple

26

27

27−typeSimple = liftM VarPT var

28+typeTuple :: (Monad m) => ParsecT [Char] u m ParseType

29+typeTuple = do ts <- betwixtSpcs '(' ')' (commaSep typeExpr)

30+ return $ case ts of { [t] -> t ; _ -> tuplePT ts }

31+

32+typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType

33+typeUnambiguous = typeList <|> typeTuple

34+

35+typeSimple :: (Monad m) => ParsecT [Char] u m ParseType

36+typeSimple = VarPT <$> var

37+

38+typeApp :: (Monad m) => ParsecT [Char] u m ParseType

28typeApp = do name <- capVar

39typeApp = do name <- capVar

29− args <- star (typeSimple +|+ typeUnambiguous)

40+ args <- many (typeSimple <|> typeUnambiguous)

30 return $ case args of

41 return $ case args of

31 [] -> VarPT name

42 [] -> VarPT name

32 _ -> ADTPT name args

43 _ -> ADTPT name args

33−

44+

45+typeExpr :: (Monad m) => ParsecT [Char] u m ParseType

34typeExpr = do

46typeExpr = do

47+ whitespace

35− t1 <- typeVar +|+ typeApp +|+ typeUnambiguous

48+ t1 <- typeVar <|> typeApp <|> typeUnambiguous

36− arrow <- optional $ t ARROW

49+ arrow <- optionMaybe arrow

37− case arrow of Just ARROW -> LambdaPT t1 `liftM` typeExpr

50+ case arrow of Just _ -> LambdaPT t1 <$> typeExpr

38 Nothing -> return t1

51 Nothing -> return t1

39

52

53+typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])

40typeConstructor = do name <- capVar

54typeConstructor = do name <- capVar

41− args <- star (typeSimple +|+ typeUnambiguous)

55+ args <- many (typeSimple <|> typeUnambiguous)

42 return $ (,) name args

56 return $ (,) name args

43

57

58+datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])

44datatype = do

59datatype = do

60+ symbol "data" <?> "datatype definition"

45− t DATA ; name <- capVar ; args <- star lowVar ; assign

61+ name <- capVar ; args <- many lowVar ; symbol "="

46− tcs <- sepBy1 (opParser (=="|")) typeConstructor

62+ tcs <- typeConstructor `sepBy1` symbol "|"

47 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)

63 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)

48

64

49−beta = VarT `liftM` guid

65+beta = liftM VarT guid

50

66

51toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames

67toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames

52 where argNames = map (("a"++) . show) [1..length args]

68 where argNames = map (("a"++) . show) [1..length args]

elm/src/Parse/Parser.hs+25−20

@@ -1,15 +1,19 @@

1−module Parser where

1+module Parser (toDefs) where

2

3import Ast

4import Control.Applicative ((<$>), (<*>))

5import Control.Monad

6import Data.Char (isSymbol, isDigit)

7import Data.List (foldl')

8−import Text.Parsec

8+import Text.Parsec hiding (newline,spaces)

9

10import ParseLib

11import Patterns

12−import Binop

12+import Binops

13+import ParseTypes

14+

15+import Guid

16+import Types (Type (VarT))

13

17

14-------- Basic Terms --------

18-------- Basic Terms --------

15

19

@@ -17,7 +21,8 @@ numTerm :: (Monad m) => ParsecT [Char] u m Expr

17numTerm = liftM (Number . read) (many1 digit) <?> "number"

21numTerm = liftM (Number . read) (many1 digit) <?> "number"

18

22

19strTerm :: (Monad m) => ParsecT [Char] u m Expr

23strTerm :: (Monad m) => ParsecT [Char] u m Expr

20−strTerm = expecting "string" . liftM Str . betwixt '"' '"' . many $ noneOf "\""

24+strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $

25+ backslashed <|> satisfy (/='"')

21

26

22varTerm :: (Monad m) => ParsecT [Char] u m Expr

27varTerm :: (Monad m) => ParsecT [Char] u m Expr

23varTerm = toVar <$> var <?> "variable"

28varTerm = toVar <$> var <?> "variable"

@@ -27,20 +32,20 @@ toVar v = case v of "True" -> Boolean True

27 _ -> Var v

32 _ -> Var v

28

33

29chrTerm :: (Monad m) => ParsecT [Char] u m Expr

34chrTerm :: (Monad m) => ParsecT [Char] u m Expr

30−chrTerm = Chr <$> betwixt '\'' '\'' anyChar <?> "character"

35+chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) <?> "character"

31

36

32

37

33-------- Complex Terms --------

38-------- Complex Terms --------

34

39

35listTerm = expecting "list" . betwixtSpcs '[' ']' $ choice

40listTerm = expecting "list" . betwixtSpcs '[' ']' $ choice

36− [ try $ do { lo <- expr; string ".." ; Range lo <$> expr }

41+ [ try $ do { lo <- expr; symbol ".." ; Range lo <$> expr }

37− , list <$> expr `sepBy` lexeme (char ',')

42+ , list <$> commaSep expr

38 ]

43 ]

39

44

40parensTerm = expecting "parenthesized expression" . betwixtSpcs '(' ')' $ choice

45parensTerm = expecting "parenthesized expression" . betwixtSpcs '(' ')' $ choice

41 [ do op <- anyOp

46 [ do op <- anyOp

42 return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")

47 return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")

43− , do es <- expr `sepBy` lexeme (char ',')

48+ , do es <- commaSep expr

44 return $ case es of { [e] -> e; _ -> tuple es }

49 return $ case es of { [e] -> e; _ -> tuple es }

45 ]

50 ]

46

51

@@ -74,7 +79,7 @@ lambdaExpr = do lexeme $ oneOf "\\\x03BB"

74 return $ makeFunction args e

79 return $ makeFunction args e

75

80

76assignExpr = do

81assignExpr = do

77− patterns <- patternTerm `endBy1` whitespace; symbol "="; exp <- expr

82+ patterns <- (patternTerm <?> "definition") `endBy1` whitespace; symbol "="; exp <- expr

78 case patterns of

83 case patterns of

79 PVar f : args -> return (f, makeFunction args exp)

84 PVar f : args -> return (f, makeFunction args exp)

80 [PData x ps] -> if "Tuple" == take 5 x && all isDigit (drop 5 x) then

85 [PData x ps] -> if "Tuple" == take 5 x && all isDigit (drop 5 x) then

@@ -100,21 +105,21 @@ caseExpr = do

100

105

101expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ]

106expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ]

102

107

103−aoeu = parse (between whitespace eof expr) ""

104−

105−symbol = lexeme . try . string

106−arrow = symbol "->" <|> symbol "\8594"

107−

108def = do (f,e) <- assignExpr

109 return ([f], [e], guid >>= \x -> return [VarT x])

110

111−{--

111+manyDefs = try (do { d <- anyDef ; ds <- many freshDef ; return (d:ds) })

112+ <|> try (many1 freshDef)

113+ where freshDef = try $ many1 freshLine >> anyDef

114+ anyDef = def <|> datatype

115+

112defs = do

116defs = do

113− (fss,ess,tss) <- unzip3 `liftM` plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype)

117+ ds <- manyDefs

118+ let (fss,ess,tss) = unzip3 ds

114 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)

119 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)

115− star $ sat (==NEWLINE) +|+ sat (==SPACES)

120+ optional freshLine ; optional whitespace ; eof

116 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)

121 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)

117

122

118−err = "Parse Error: Better error messages to come!"

119−toDefs = parse defs . ('\n':)

123+toDefs source = case parse defs "Elm code" source of

120−--}

124+ Right result -> Right result

125+ Left err -> Left $ show err