35981eb · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Finish parameterizing the AST and properly check errors in let expressions.

35981ebevancz13 years ago

Elm.cabal+2

compare with master

unifiedsplit

@@ -81,6 +81,7 @@ Library

81 template-haskell,

82 pandoc >= 1.10,

83 bytestring,

84+ uniplate,

84 hjsmin,

85 hjsmin,

85 indents,

86 indents,

86 filepath,

87 filepath,

@@ -136,6 +137,7 @@ Executable elm

136 cmdargs,

137 cmdargs,

137 pandoc >= 1.10,

138 pandoc >= 1.10,

138 bytestring,

139 bytestring,

140+ uniplate,

139 hjsmin,

141 hjsmin,

140 indents,

142 indents,

141 filepath,

143 filepath,

compiler/Compiler.hs+1−1

@@ -102,7 +102,7 @@ buildFile flags moduleNum numModules filePath =

102 if takeExtension filePath == ".js" then return ("",source) else

103 case buildFromSource (no_prelude flags) source of

104 Left err -> putStrLn err >> exitFailure

105− Right modul -> do exs <- exportInfo modul

105+ Right modul -> do exs <- exportInfo (modul :: Module () String)

106 return (exs, jsModule modul)

107 createDirectoryIfMissing True (output_directory flags)

108 writeFile (elmo flags filePath) obj

compiler/Initialize.hs+5−5

@@ -4,7 +4,7 @@ import Control.Applicative ((<$>))

4import Control.Monad.Error

5import Data.List (lookup,nub)

6import qualified Data.Map as Map

7−

7+import Data.Data

8import SourceSyntax.Everything

9import Data.List (intercalate,partition)

10import Parse.Parser (parseProgram, parseDependencies)

@@ -17,21 +17,21 @@ import Transform.Optimize

17import System.Exit

18import System.FilePath

20−checkMistakes :: Module t v -> Either String (Module t v)

20+checkMistakes :: (Data t, Data v) => Module t v -> Either String (Module t v)

21checkMistakes modul@(Module name ex im stmts) =

22 case mistakes stmts of

23 m:ms -> Left (unlines (m:ms))

24 [] -> return modul

26−checkTypes :: Module t v -> Either String (Module t v)

26+checkTypes :: (Data t, Data v) => Module t v -> Either String (Module t v)

27checkTypes modul =

28 do subs <- unify hints modul

29 subs `seq` return (optimize (renameModule modul))

31−check :: Module t v -> Either String (Module t v)

31+check :: (Data t, Data v) => Module t v -> Either String (Module t v)

32check = checkMistakes >=> checkTypes

34−buildFromSource :: Bool -> String -> Either String (Module t v)

34+buildFromSource :: (Data t, Data v) => Bool -> String -> Either String (Module t v)

35buildFromSource noPrelude src =

36 let add = if noPrelude then id else Libs.addPrelude in

37 (check . add) =<< (parseProgram src)

compiler/Language/Elm.hs+2

@@ -18,6 +18,7 @@ import Generate.Html (generateHtml)

18import Initialize (buildFromSource)

19import Parse.Helpers

20import Parse.Module (moduleDef)

21+import SourceSyntax.Module

21import Text.Blaze.Html (Html)

22import Text.Blaze.Html (Html)

22import Text.Parsec (option,optional)

23import Text.Parsec (option,optional)

23import Paths_Elm

24import Paths_Elm

@@ -27,6 +28,7 @@ import Paths_Elm

27compile :: String -> Either String String

28compile :: String -> Either String String

28compile source = fmap jsModule modul

29compile source = fmap jsModule modul

29 where

30 where

31+ modul :: Either String (Module () String)

30 modul = buildFromSource False source

32 modul = buildFromSource False source

32-- |This function extracts the module name of a given source program.

34-- |This function extracts the module name of a given source program.

compiler/Types/Alias.hs+61−41

@@ -9,6 +9,7 @@ import qualified Data.Set as Set

9import Types.Substitutions (subst)

10import Types.Types

11import Data.Data

12+import Data.Generics.Uniplate.Data

13builtins :: [(String,([X],Type))]

14builtins :: [(String,([X],Type))]

14builtins =

15builtins =

@@ -28,13 +29,16 @@ builtins =

28 ("LineStyle", ([], makeRecord line))

29 ("LineStyle", ([], makeRecord line))

29 ]

30 ]

31−get :: [Declaration t v] -> Map.Map String ([X],Type)

32+type AliasDict = Map.Map String ([X],Type)

32−get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)

33− where getAlias stmt = case stmt of

34− TypeAlias alias xs t -> [(alias, (xs,t))]

35− _ -> []

34+get :: [Declaration t v] -> AliasDict

35+get decl = Map.fromList (builtins ++ concatMap getAlias decl)

36+ where

37+ getAlias decl = case decl of

38+ TypeAlias alias xs t -> [(alias, (xs,t))]

39+ _ -> []

40+

37−dealias :: Map.Map String ([X],Type) -> Type -> Type

41+dealias :: AliasDict -> Type -> Type

38dealias aliases t =

42dealias aliases t =

39 let f = dealias aliases in

43 let f = dealias aliases in

40 case t of

44 case t of

@@ -45,38 +49,54 @@ dealias aliases t =

45 RecordT r t -> RecordT (Map.map (map f) r) (f t)

49 RecordT r t -> RecordT (Map.map (map f) r) (f t)

46 _ -> t

50 _ -> t

48−mistakes :: [Declaration t v] -> [String]

52+--mistakes :: [Def t v] -> [String]

49−mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts

53+mistakes defs = badKinds defs -- ++ dups defs ++ badOrder defs

54+

55+extractDefs :: [Declaration t v] -> [Def t v]

56+extractDefs = concatMap keepDef

57+ where

58+ keepDef decl = case decl of

59+ Definition def -> [def]

60+ _ -> []

51−badKinds :: [Declaration t v] -> [String]

62+badKinds :: (Data t, Data v) => [Declaration t v] -> [String]

52−badKinds stmts = map msg (concatMap badS stmts)

63+badKinds decls = map msg (concatMap bad decls)

53 where

64 where

54 msg x = "Type Error: Type alias '" ++ x ++

65 msg x = "Type Error: Type alias '" ++ x ++

55 "' was given the wrong number of arguments."

66 "' was given the wrong number of arguments."

68+ aliases :: AliasDict

69+ aliases = Map.empty

70+

57− badT :: Type -> [String]

71+ badType :: Type -> [String]

58− badT t =

72+ badType t =

59− case t of

73+ case t of

60− ADT name ts ->

74+ ADT name ts ->

61− case Map.lookup name (get stmts) of

75+ case Map.lookup name aliases of

62− Just (xs,t) | length xs == length ts -> []

76+ Just (xs,t) | length xs == length ts -> []

63− | otherwise -> [name]

77+ | otherwise -> [name]

64− Nothing -> concatMap badT ts

78+ Nothing -> concatMap badType ts

65− LambdaT t u -> badT t ++ badT u

79+ LambdaT t u -> badType t ++ badType u

66− RecordT r t -> badT t ++ concatMap badT (concat (Map.elems r))

80+ RecordT r t -> badType t ++ concatMap badType (concat (Map.elems r))

67− _ -> []

81+ _ -> []

68−

82+

83+ --badDef :: AliasDict -> Def t v -> [String]

84+ badDef def =

85+ case def of

86+ TypeAnnotation _ tipe -> badType tipe

87+ FnDef _ _ expr ->

88+ concatMap badDef $ concat [defList | Let defList _ <- universeBi expr]

89+ OpDef _ _ _ expr ->

90+ concatMap badDef $ concat [defList | Let defList _ <- universeBi expr]

91+

69− badS :: Declaration t v -> [String]

92+ --bad :: Declaration t v -> [String]

70− badS s =

93+ bad s =

71 case s of

94 case s of

72− Datatype _ _ tcs -> concatMap badT (concatMap snd tcs)

95+ Datatype _ _ tcs -> concatMap badType (concatMap snd tcs)

73− ExportEvent _ _ tipe -> badT tipe

96+ ExportEvent _ _ tipe -> badType tipe

74− ImportEvent _ _ _ tipe -> badT tipe

97+ ImportEvent _ _ _ tipe -> badType tipe

75− TypeAlias _ _ tipe -> badT tipe

98+ TypeAlias _ _ tipe -> badType tipe

76− Definition d ->

99+ Definition d -> badDef d

77− case d of

78− TypeAnnotation _ tipe -> badT tipe

79− _ -> []

100

81annotation :: Declaration t v -> [String]

101annotation :: Declaration t v -> [String]

82annotation s =

102annotation s =

@@ -97,22 +117,22 @@ defName d =

97 OpDef n _ _ _ -> n

117 OpDef n _ _ _ -> n

118

99dups :: [Declaration t v] -> [String]

119dups :: [Declaration t v] -> [String]

100−dups stmts = map defMsg (dup definition) ++ map annMsg (dup annotation)

120+dups defs = map defMsg (dup definition) ++ map annMsg (dup annotation)

101 where

121 where

102 --dup :: (Declaration t v -> [String]) -> [String]

122 --dup :: (Declaration t v -> [String]) -> [String]

103− dup f = map head . filter ((>1) . length) . group . sort $ concatMap f stmts

123+ dup f = map head . filter ((>1) . length) . group . sort $ concatMap f defs

104

124

105 msg = "Syntax Error: There can only be one "

125 msg = "Syntax Error: There can only be one "

106 defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."

126 defMsg x = msg ++ "top-level definition of '" ++ x ++ "'."

107 annMsg x = msg ++ "type annotation for '" ++ x ++ "'."

127 annMsg x = msg ++ "type annotation for '" ++ x ++ "'."

108

128

109−badOrder :: [Declaration t v] -> [String]

129+--badOrder :: [Def t v] -> [String]

110−badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs stmts)

130+badOrder defs = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualPairs defs)

111 where

131 where

112 msg x = "Syntax Error: The type annotation for '" ++ x ++

132 msg x = "Syntax Error: The type annotation for '" ++ x ++

113 "' must be directly above its definition."

133 "' must be directly above its definition."

114− as = sort $ concatMap annotation stmts

134+ as = sort $ concatMap annotation defs

115− ds = sort $ concatMap definition stmts

135+ ds = sort $ concatMap definition defs

116

136

117 expectedPairs :: [String] -> [String] -> [String]

137 expectedPairs :: [String] -> [String] -> [String]

118 expectedPairs as ds =

138 expectedPairs as ds =

@@ -123,9 +143,9 @@ badOrder stmts = map msg $ missings (sort $ expectedPairs as ds) (sort $ actualP

123 GT -> expectedPairs (x:xs) ys

143 GT -> expectedPairs (x:xs) ys

124 ( _ , _ ) -> []

144 ( _ , _ ) -> []

125

145

126− --actualPairs :: [Declaration t v] -> [String]

146+ --actualPairs :: [Def t v] -> [String]

127− actualPairs stmts =

147+ actualPairs defs =

128− case stmts of

148+ case defs of

129 Definition (TypeAnnotation n _) : Definition d : rest ->

149 Definition (TypeAnnotation n _) : Definition d : rest ->

130 (if n == defName d then [n] else []) ++ actualPairs rest

150 (if n == defName d then [n] else []) ++ actualPairs rest

131 t:s:rest -> actualPairs (s:rest)

151 t:s:rest -> actualPairs (s:rest)