git.iko.soy/elk
on fdb21df help sign in
elk/src/Nitpick/TopLevelTypes.hs
125 lines 2.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2module Nitpick.TopLevelTypes (topLevelTypes) where
4import qualified Data.Foldable as F
5import Data.Map ((!))
6import qualified Data.Map as Map
8import qualified AST.Expression.Canonical as Can
9import qualified AST.Expression.General as Expr
10import qualified AST.Module.Name as ModuleName
11import qualified AST.Pattern as P
12import qualified AST.Type as Type
13import qualified AST.Variable as Var
14import qualified Canonicalize.Effects as Effects
15import qualified Elm.Package as Pkg
16import qualified Reporting.Annotation as A
17import qualified Reporting.Error.Type as Error
18import qualified Reporting.Result as Result
19import qualified Reporting.Warning as Warning
23type Result =
24 Result.Result () Warning.Warning Error.Error
27type TypeDict =
28 Map.Map String Type.Canonical
32-- CHECK TOP LEVEL TYPES
35topLevelTypes :: TypeDict -> Can.SortedDefs -> Result [Can.Def]
36topLevelTypes typeEnv sortedDefs =
37 let
38 check =
39 checkAnnotation typeEnv
40 in
41 case sortedDefs of
42 Can.NoMain defs ->
43 pure defs
44 <* F.traverse_ check defs
46 Can.YesMain before main after ->
47 do check main
48 <* F.traverse_ check before
49 <* F.traverse_ check after
51 mainDef <- checkMain typeEnv main
53 return (before ++ mainDef : after)
57-- MISSING ANNOTATIONS
60checkAnnotation :: TypeDict -> Can.Def -> Result ()
61checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =
62 case (pattern, maybeType) of
63 (P.Var name, Nothing) ->
64 let
65 warning =
66 Warning.MissingTypeAnnotation name (typeEnv ! name)
67 in
68 Result.warn region warning ()
70 _ ->
71 return ()
75-- CHECK MAIN TYPE
78checkMain :: TypeDict -> Can.Def -> Result Can.Def
79checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
80 let
81 mainType =
82 typeEnv ! "main"
84 makeError tipe maybeMsg =
85 A.A region (Error.BadFlags tipe maybeMsg)
87 getMainKind =
88 case Type.deepDealias mainType of
89 Type.App name [arg]
90 | name == vdomNode ->
91 return Expr.VDom
93 | name == program && arg == never ->
94 return Expr.NoFlags
96 | name == program ->
97 return (Expr.Flags arg)
98 <* Effects.checkForeignType makeError arg
100 _ ->
101 Result.throw region (Error.BadMain mainType)
102 in
103 do kind <- getMainKind
104 let newBody = A.A undefined (Expr.Program kind body)
105 return (Can.Def facts pattern newBody maybeType)
108program :: Type.Canonical
109program =
110 Type.Type (Var.inCore ["Platform"] "Program")
113never :: Type.Canonical
114never =
115 Type.Type (Var.inCore ["Basics"] "Never")
118vdomNode :: Type.Canonical
119vdomNode =
120 let
121 vdom =
122 ModuleName.Canonical Pkg.virtualDom ["VirtualDom"]
123 in
124 Type.Type (Var.fromModule vdom "Node")