276ad25 · elk · git.iko.soy

elm-compiler.cabal+1−1

compare with master

unifiedsplit

@@ -76,6 +76,7 @@ Library

76 Generate.JavaScript.Port,

77 Generate.JavaScript.Variable,

78 Generate.Substitute,

79+ Nitpick.TopLevelTypes,

79 Parse.Binop,

80 Parse.Binop,

80 Parse.Declaration,

81 Parse.Declaration,

81 Parse.Expression,

82 Parse.Expression,

@@ -99,7 +100,6 @@ Library

99 Type.Constrain.Literal,

100 Type.Constrain.Literal,

100 Type.Constrain.Pattern,

101 Type.Constrain.Pattern,

101 Type.Environment,

102 Type.Environment,

102− Type.ExtraChecks,

103 Type.Fragment,

104 Type.Inference,

105 Type.PrettyPrint,

src/Compile.hs+6−1

@@ -5,6 +5,7 @@ import qualified Data.Map as Map

5import qualified AST.Module as Module

6import qualified Canonicalize

7import Elm.Utils ((|>))

8+import qualified Nitpick.TopLevelTypes as Nitpick

8import qualified Parse.Helpers as Parse

9import qualified Parse.Helpers as Parse

9import qualified Parse.Parse as Parse

10import qualified Parse.Parse as Parse

10import qualified Reporting.Error as Error

11import qualified Reporting.Error as Error

@@ -41,7 +42,11 @@ compile user projectName interfaces source =

41 Result.from Error.Type $

42 Result.from Error.Type $

42 TI.infer interfaces canonicalModule

43 TI.infer interfaces canonicalModule

43

44

45+ -- One last round of checks

46+ Result.mapError Error.Type $

47+ Nitpick.topLevelTypes types (Module.body validModule)

48+

44− -- Add the real list of tyes

49+ -- Add the real list of types

45 let body = (Module.body canonicalModule) { Module.types = types }

50 let body = (Module.body canonicalModule) { Module.types = types }

46

51

47 return $ canonicalModule { Module.body = body }

52 return $ canonicalModule { Module.body = body }

src/Nitpick/TopLevelTypes.hsnew file+115

@@ -0,0 +1,115 @@

1+{-# OPTIONS_GHC -Wall #-}

2+module Nitpick.TopLevelTypes (topLevelTypes) where

3+

4+import Prelude hiding (maybe)

5+import qualified Data.Foldable as F

6+import qualified Data.Map as Map

7+

8+import qualified AST.Expression.Valid as Valid

9+import qualified AST.Declaration as Decl

10+import qualified AST.Pattern as P

11+import qualified AST.Type as Type

12+import qualified AST.Variable as Var

13+import qualified Reporting.Annotation as A

14+import qualified Reporting.Error.Type as Error

15+import qualified Reporting.Result as Result

16+import qualified Reporting.Warning as Warning

17+

18+

19+topLevelTypes

20+ :: Map.Map String Type.Canonical

21+ -> [Decl.ValidDecl]

22+ -> Result.Result Warning.Warning Error.Error ()

23+topLevelTypes typeEnv validDecls =

24+ do F.traverse_ (warnMissingAnnotation typeEnv) validDecls

25+ checkMainType typeEnv validDecls

26+

27+

28+-- MISSING ANNOTATIONS

29+

30+warnMissingAnnotation

31+ :: Map.Map String Type.Canonical

32+ -> Decl.ValidDecl

33+ -> Result.Result Warning.Warning Error.Error ()

34+warnMissingAnnotation typeEnv (A.A region decl) =

35+ case decl of

36+ Decl.Definition (Valid.Definition (A.A _ (P.Var name)) _ Nothing) ->

37+ case Map.lookup name typeEnv of

38+ Nothing ->

39+ return ()

40+ Just tipe ->

41+ Result.warn region (Warning.MissingTypeAnnotation name tipe)

42+ _ ->

43+ return ()

44+

45+

46+-- MAIN TYPE

47+

48+checkMainType

49+ :: Map.Map String Type.Canonical

50+ -> [Decl.ValidDecl]

51+ -> Result.Result w Error.Error ()

52+checkMainType typeEnv decls =

53+ case decls of

54+ A.A region (Decl.Definition (Valid.Definition (A.A _ (P.Var "main")) _ _)) : _ ->

55+ case Map.lookup "main" typeEnv of

56+ Nothing ->

57+ return ()

58+

59+ Just typeOfMain ->

60+ let tipe = Type.deepDealias typeOfMain

61+ in

62+ if tipe `elem` validMainTypes

63+ then return ()

64+ else Result.throw region (Error.BadMain typeOfMain)

65+

66+ _ : remainingDecls ->

67+ checkMainType typeEnv remainingDecls

68+

69+ [] ->

70+ return ()

71+

72+

73+validMainTypes :: [Type.Canonical]

74+validMainTypes =

75+ [ element

76+ , html

77+ , signal element

78+ , signal html

79+ ]

80+ where

81+ fromModule :: [String] -> String -> Type.Canonical

82+ fromModule home name =

83+ Type.Type (Var.fromModule home name)

84+

85+ html =

86+ fromModule ["VirtualDom"] "Node"

87+

88+ signal tipe =

89+ Type.App (fromModule ["Signal"] "Signal") [ tipe ]

90+

91+ element =

92+ let builtin name =

93+ Type.Type (Var.builtin name)

94+

95+ maybe tipe =

96+ Type.App (fromModule ["Maybe"] "Maybe") [ tipe ]

97+ in

98+ Type.Record

99+ [ ("element", fromModule ["Graphics","Element"] "ElementPrim")

100+ , ("props",

101+ Type.Record

102+ [ ("click" , builtin "_Tuple0")

103+ , ("color" , maybe (fromModule ["Color"] "Color"))

104+ , ("height" , builtin "Int")

105+ , ("hover" , builtin "_Tuple0")

106+ , ("href" , builtin "String")

107+ , ("id" , builtin "Int")

108+ , ("opacity", builtin "Float")

109+ , ("tag" , builtin "String")

110+ , ("width" , builtin "Int")

111+ ]

112+ Nothing

113+ )

114+ ]

115+ Nothing

src/Reporting/Warning.hs+2−20

@@ -1,27 +1,9 @@

1module Reporting.Warning where

2

3import qualified AST.Module as Module

4−

5−import qualified Reporting.Annotation as A

4+import qualified AST.Type as Type

6

5

7

6

8data Warning

7data Warning

9 = UnusedImport Module.Name

8 = UnusedImport Module.Name

10− | MissingTypeAnnotation String

9+ | MissingTypeAnnotation String Type.Canonical

11−

12−

13−-- TO STRING

14−

15−toString :: A.Located Warning -> String

16−toString (A.A region warning) =

17− case warning of

18− _ -> error "Warning.toString" region

19−

20−

21−-- TO JSON

22−

23−toJson :: A.Located Warning -> String

24−toJson (A.A region warning) =

25− case warning of

26− _ -> error "Warning.toJson" region

27−

src/Type/ExtraChecks.hsdeleted−78

@@ -1,78 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−

3−{-| This module contains checks to be run *after* type inference has completed

4−successfully. At that point we still need to ensure that `main` has an

5−acceptable type.

6−-}

7−module Type.ExtraChecks (mainType) where

8−

9−import Prelude hiding (maybe)

10−import Control.Monad.Except (ExceptT, throwError)

11−import qualified Data.Map as Map

12−

13−import qualified AST.Type as ST

14−import qualified AST.Variable as Var

15−

16−

17−-- MAIN TYPE

18−

19−mainType

20− :: (Monad m)

21− => Map.Map String ST.Canonical

22− -> ExceptT ST.Canonical m ()

23−mainType env =

24− case Map.lookup "main" env of

25− Nothing ->

26− return ()

27−

28− Just typeOfMain ->

29− let tipe = ST.deepDealias typeOfMain

30− in

31− if tipe `elem` validMainTypes

32− then return ()

33− else throwError typeOfMain

34−

35−

36−validMainTypes :: [ST.Canonical]

37−validMainTypes =

38− [ element

39− , html

40− , signal element

41− , signal html

42− ]

43− where

44− fromModule :: [String] -> String -> ST.Canonical

45− fromModule home name =

46− ST.Type (Var.fromModule home name)

47−

48− html =

49− fromModule ["VirtualDom"] "Node"

50−

51− signal tipe =

52− ST.App (fromModule ["Signal"] "Signal") [ tipe ]

53−

54− element =

55− let builtin name =

56− ST.Type (Var.builtin name)

57−

58− maybe tipe =

59− ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]

60− in

61− ST.Record

62− [ ("element", fromModule ["Graphics","Element"] "ElementPrim")

63− , ("props",

64− ST.Record

65− [ ("click" , builtin "_Tuple0")

66− , ("color" , maybe (fromModule ["Color"] "Color"))

67− , ("height" , builtin "Int")

68− , ("hover" , builtin "_Tuple0")

69− , ("href" , builtin "String")

70− , ("id" , builtin "Int")

71− , ("opacity", builtin "Float")

72− , ("tag" , builtin "String")

73− , ("width" , builtin "Int")

74− ]

75− Nothing

76− )

77− ]

78− Nothing

src/Type/Inference.hs+2−10

@@ -1,7 +1,7 @@

1module Type.Inference where

2

3import Control.Arrow (first, second)

4−import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError, withExceptT)

4+import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)

5import qualified Data.Map as Map

6import qualified Data.Traversable as Traverse

7

@@ -12,7 +12,6 @@ import qualified Reporting.Annotation as A

12import qualified Reporting.Error.Type as Error

13import qualified Type.Constrain.Expression as TcExpr

14import qualified Type.Environment as Env

15−import qualified Type.ExtraChecks as Check

16import qualified Type.Solve as Solve

15import qualified Type.Solve as Solve

17import qualified Type.State as TS

16import qualified Type.State as TS

18import qualified Type.Type as T

17import qualified Type.Type as T

@@ -36,14 +35,7 @@ infer interfaces modul =

36 let header' = Map.delete "::" header

35 let header' = Map.delete "::" header

37 let types = Map.difference (TS.sSavedEnv state) header'

36 let types = Map.difference (TS.sSavedEnv state) header'

38

37

39− srcTypes <-

40− liftIO (Traverse.traverse T.toSrcType types)

38+ liftIO (Traverse.traverse T.toSrcType types)

41−

42− withExceptT

43− (\tipe -> [A.A (error "TODO:infer") (Error.BadMain tipe)])

44− (Check.mainType srcTypes)

45−

46− return srcTypes

47

39

48

40

49genConstraints

41genConstraints