42b4d55 · elk · git.iko.soy

Build.hs+4−1

compare with master

unifiedsplit

@@ -10,6 +10,7 @@ import System.IO

10import Language.Elm

11

12rts = "compiler" </> "elm-runtime.js"

13+types = "compiler" </> "types.json"

13

14

14getFiles ext dir = do

15getFiles ext dir = do

15 contents <- map (dir </>) `fmap` getDirectoryContents dir

16 contents <- map (dir </>) `fmap` getDirectoryContents dir

@@ -34,10 +35,12 @@ main = do

34 writeFile rts "Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\

35 writeFile rts "Elm = {}; Elm.Native = {}; Elm.Native.Graphics = {};\n\

35 \Elm.Graphics = {}; ElmRuntime = {}; ElmRuntime.Render = {}\n"

36 \Elm.Graphics = {}; ElmRuntime = {}; ElmRuntime.Render = {}\n"

36 mapM_ appendJS =<< getFiles ".js" "libraries"

37 mapM_ appendJS =<< getFiles ".js" "libraries"

37− mapM_ appendElm =<< getFiles ".elm" "libraries"

38+ files <- getFiles ".elm" "libraries"

39+ mapM_ appendElm files

38 mapM_ appendJS =<< getFiles ".js" "runtime"

40 mapM_ appendJS =<< getFiles ".js" "runtime"

39 putStrLn "\n+------------------------------------------+\

41 putStrLn "\n+------------------------------------------+\

40 \\n| Success building runtime and libraries! |\

42 \\n| Success building runtime and libraries! |\

41 \\n+------------------------------------------+\n"

43 \\n+------------------------------------------+\n"

44+ system ("elm-doc " ++ unwords files ++ " > " ++ types)

42 system ("cabal install compiler" </> "Elm.cabal")

45 system ("cabal install compiler" </> "Elm.cabal")

43 exitSuccess

46 exitSuccess

compiler/Elm.cabal+22−3

@@ -66,10 +66,10 @@ Library

66 containers >= 0.3,

67 transformers >= 0.2,

68 mtl >= 2,

69+ deepseq,

69 parsec >= 3.1.1,

70 parsec >= 3.1.1,

70 blaze-html == 0.5.*,

71 blaze-html == 0.5.*,

71 blaze-markup == 0.5.1.*,

72 blaze-markup == 0.5.1.*,

72− deepseq,

73 text,

74 template-haskell,

75 shakespeare >= 1,

@@ -115,13 +115,32 @@ Executable elm

115 containers >= 0.3,

116 transformers >= 0.2,

117 mtl >= 2,

118+ deepseq,

118 parsec >= 3.1.1,

119 parsec >= 3.1.1,

119 blaze-html == 0.5.*,

120 blaze-html == 0.5.*,

120 blaze-markup == 0.5.1.*,

121 blaze-markup == 0.5.1.*,

121− deepseq,

122 cmdargs,

123 pandoc >= 1.10,

124 bytestring,

125 hjsmin,

126 indents,

127− filepath

127+ filepath

128+

129+Executable elm-doc

130+ Main-is: Docs.hs

131+ Hs-Source-Dirs: src

132+ other-modules: Ast,

133+ Context,

134+ Parse.Library,

135+ Parse.Modules,

136+ Parse.Types,

137+ Types.Types

138+

139+ Build-depends: base >=4.2 && <5,

140+ containers >= 0.3,

141+ transformers >= 0.2,

142+ mtl >= 2,

143+ parsec >= 3.1.1,

144+ pandoc >= 1.10,

145+ cmdargs,

146+ indents

compiler/src/Ast.hs+23−21

@@ -73,24 +73,26 @@ plist = foldr pcons pnil

73ptuple es = PData ("Tuple" ++ show (length es)) es

74

75brkt s = "{ " ++ s ++ " }"

76+parensIf b s = if b then parens s else s

76

77

77instance Show Pattern where

78instance Show Pattern where

79+ show p =

80+ case p of

78− show (PRecord fs) = brkt (intercalate ", " fs)

81+ PRecord fs -> brkt (intercalate ", " fs)

79− show (PVar x) = x

82+ PVar x -> x

80− show PAnything = "_"

83+ PAnything -> "_"

81− show (PData "Cons" [hd@(PData "Cons" _),tl]) =

84+ PData "Cons" [hd@(PData "Cons" _),tl] ->

82− parens (show hd) ++ " : " ++ show tl

85+ parens (show hd) ++ " :: " ++ show tl

83− where parens s = "(" ++ s ++ ")"

84− show (PData "Cons" [hd,tl]) = show hd ++ " : " ++ show tl

86+ PData "Cons" [hd,tl] -> show hd ++ " : " ++ show tl

85− show (PData "Nil" []) = "[]"

87+ PData "Nil" [] -> "[]"

86− show (PData name ps) =

88+ PData name ps ->

87 if take 5 name == "Tuple" && all isDigit (drop 5 name) then

89 if take 5 name == "Tuple" && all isDigit (drop 5 name) then

88 parens . intercalate ", " $ map show ps

90 parens . intercalate ", " $ map show ps

89− else (if null ps then id else parens) $ unwords (name : map show ps)

91+ else parensIf (not (null ps)) $ unwords (name : map show ps)

90− where parens s = "(" ++ s ++ ")"

91

92

92instance Show Expr where

93instance Show Expr where

93 show e =

94 show e =

95+ let show' (C _ _ e) = parensIf (needsParens e) (show e) in

94 case e of

96 case e of

95 IntNum n -> show n

97 IntNum n -> show n

96 FloatNum n -> show n

98 FloatNum n -> show n

@@ -138,13 +140,13 @@ getLambdas (C _ _ (Lambda x e)) = (x:xs,e')

138 where (xs,e') = getLambdas e

140 where (xs,e') = getLambdas e

139getLambdas e = ([],e)

141getLambdas e = ([],e)

140

142

141−show' (C _ _ e) = if needsParens e then "(" ++ show e ++ ")" else show e

143+needsParens e =

142−

144+ case e of

143−needsParens (Binop _ _ _) = True

145+ Binop _ _ _ -> True

144−needsParens (Lambda _ _) = True

146+ Lambda _ _ -> True

145−needsParens (App _ _) = True

147+ App _ _ -> True

146−needsParens (If _ _ _) = True

148+ If _ _ _ -> True

147−needsParens (Let _ _) = True

149+ Let _ _ -> True

148−needsParens (Case _ _) = True

150+ Case _ _ -> True

149−needsParens (Data name (x:xs)) = name /= "Cons"

151+ Data name (x:xs) -> name /= "Cons"

150−needsParens _ = False

152+ _ -> False

compiler/src/Compiler.hs+3−1

@@ -6,6 +6,7 @@ import Data.List (intersect, intercalate)

6import Data.Maybe (fromMaybe)

7import Data.Version (showVersion)

8import System.Console.CmdArgs

9+import System.Exit

9import System.FilePath

10import System.FilePath

10import Text.Blaze.Html.Renderer.String (renderHtml)

11import Text.Blaze.Html.Renderer.String (renderHtml)

11

12

@@ -68,7 +69,8 @@ fileTo isMini make what jsFiles noscript outputDir rtLoc file = do

68 return (fmap (:[]) (buildFromSource src))

69 return (fmap (:[]) (buildFromSource src))

69 jss <- concat `fmap` mapM readFile jsFiles

70 jss <- concat `fmap` mapM readFile jsFiles

70 case ems of

71 case ems of

71− Left err -> putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err

72+ Left err -> do putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err

73+ exitFailure

72 Right ms ->

74 Right ms ->

73 let path = fromMaybe "" outputDir </> file

75 let path = fromMaybe "" outputDir </> file

74 js = replaceExtension path ".js"

76 js = replaceExtension path ".js"

compiler/src/Docs.hsnew file+49

@@ -0,0 +1,49 @@

1+

2+module Main where

3+

4+import Ast

5+import Control.Applicative ((<$>), (<*>))

6+import Data.List as List

7+import Parse.Library

8+import Parse.Modules (moduleDef)

9+import Parse.Types (typeAnnotation)

10+import System.Environment

11+import System.Exit

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

13+import Types.Types

14+

15+

16+main = do

17+ srcs <- mapM readFile =<< getArgs

18+ case mapM docParse srcs of

19+ Left err -> putStrLn err >> exitFailure

20+ Right ms -> putStrLn (toModules ms)

21+

22+toModules ms =

23+ "{ \"modules\" : [\n " ++ intercalate ",\n " (map toModule ms) ++ "\n ]\n}"

24+

25+toModule (name, values) =

26+ "{ \"module\" : " ++ show name ++ ",\n \"values\" : [\n " ++ vs ++ "\n ]\n }"

27+ where vs = intercalate ",\n " (map toValue values)

28+

29+toValue (name, tipe) =

30+ "{ \"name\" : " ++ show name ++ ",\n \"type\" : \"" ++ show tipe ++ "\"\n }"

31+

32+docParse :: String -> Either String (String, [(String, Type)])

33+docParse = setupParser $ do

34+ optional freshLine

35+ (,) <$> option "Main" moduleName <*> types

36+ where

37+ skip = manyTill anyChar simpleNewline >> return []

38+ end = many1 anyChar >> return []

39+ tipe = get <$> try typeAnnotation

40+ get stmt = case stmt of { TypeAnnotation n t -> [(n,t)] ; _ -> [] }

41+ types = concat <$> many (tipe <|> try skip <|> end)

42+ getName = intercalate "." . fst

43+ moduleName = do optional freshLine

44+ getName <$> moduleDef `followedBy` freshLine

45+

46+setupParser p source =

47+ case iParse p "" source of

48+ Right result -> Right result

49+ Left err -> Left $ "Parse error at " ++ show err

compiler/src/Types/Types.hs+23−22

@@ -86,28 +86,29 @@ parens = ("("++) . (++")")

86

87instance Show Type where

88 show t =

89− case t of

89+ let show' t = case t of { LambdaT _ _ -> parens (show t) ; _ -> show t }

90+ in case t of

90− { LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2

91+ LambdaT t1@(LambdaT _ _) t2 -> show' t1 ++ " -> " ++ show t2

91− ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2

92+ LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2

92− ; VarT x -> 't' : show x

93+ VarT x -> 't' : show x

93− ; ADT "List" [ADT "Char" []] -> "String"

94+ ADT "List" [ADT "Char" []] -> "String"

94− ; ADT "List" [tipe] -> "[" ++ show tipe ++ "]"

95+ ADT "List" [tipe] -> "[" ++ show tipe ++ "]"

95− ; ADT name cs ->

96+ ADT name cs ->

96− if isTupleString name

97+ if isTupleString name

97− then parens . intercalate "," $ map show cs

98+ then parens . intercalate "," $ map show cs

98− else case cs of

99+ else case cs of

99− [] -> name

100+ [] -> name

100− _ -> parens $ name ++ " " ++ unwords (map show cs)

101+ _ -> name ++ " " ++ unwords (map show cs)

101− ; Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"

102+ Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"

102− ; EmptyRecord -> "{}"

103+ EmptyRecord -> "{}"

103− ; RecordT fs t ->

104+ RecordT fs t ->

104− start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"

105+ start ++ intercalate ", " (concatMap fields $ Map.toList fs) ++ " }"

105− where field n s = n ++ " :: " ++ show s

106+ where field n s = n ++ " :: " ++ show s

106− fields (n,ss) = map (field n) ss

107+ fields (n,ss) = map (field n) ss

107− start = case t of

108+ start = case t of

108− EmptyRecord -> "{ "

109+ EmptyRecord -> "{ "

109− _ -> "{ " ++ show t ++ " | "

110+ _ -> "{ " ++ show t ++ " | "

110− }

111+

111

112

112instance Show Scheme where

113instance Show Scheme where

113 show (Forall [] [] t) = show t

114 show (Forall [] [] t) = show t

libraries/Graphics/Color.elm+1−1

@@ -47,4 +47,4 @@ data Gradient

47 | Radial [(Float,Color)] (Float,Float) Float (Float,Float) Float

48

49linear = Linear

50−radial = Radial

50+radial = Radial