git.iko.soy/elk
on e5093cd 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.Module.Name as ModuleName
10import qualified AST.Pattern as P
11import qualified AST.Type as Type
12import qualified AST.Variable as Var
13import qualified Canonicalize.Effects as Effects
14import qualified Elm.Package as Pkg
15import qualified Reporting.Annotation as A
16import qualified Reporting.Error.Type as Error
17import qualified Reporting.Result as Result
18import qualified Reporting.Warning as Warning
22type Result =
23 Result.Result () Warning.Warning Error.Error
26type TypeDict =
27 Map.Map String Type.Canonical
31-- CHECK TOP LEVEL TYPES
34topLevelTypes :: TypeDict -> Can.SortedDefs -> Result [Can.Def]
35topLevelTypes typeEnv sortedDefs =
36 let
37 check =
38 checkAnnotation typeEnv
39 in
40 case sortedDefs of
41 Can.NoMain defs ->
42 pure defs
43 <* F.traverse_ check defs
45 Can.YesMain before main after ->
46 do check main
47 <* F.traverse_ check before
48 <* F.traverse_ check after
50 mainDef <- checkMain typeEnv main
52 return (before ++ mainDef : after)
56-- MISSING ANNOTATIONS
59checkAnnotation :: TypeDict -> Can.Def -> Result ()
60checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =
61 case (pattern, maybeType) of
62 (P.Var name, Nothing) ->
63 let
64 warning =
65 Warning.MissingTypeAnnotation name (typeEnv ! name)
66 in
67 Result.warn region warning ()
69 _ ->
70 return ()
74-- CHECK MAIN TYPE
77checkMain :: TypeDict -> Can.Def -> Result Can.Def
78checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
79 let
80 mainType =
81 typeEnv ! "main"
83 makeError tipe maybeMsg =
84 A.A region (Error.BadFlags tipe maybeMsg)
86 getMainKind =
87 case Type.deepDealias mainType of
88 Type.App name [_]
89 | name == vdomNode ->
90 return Can.VDom
92 Type.App name [flags, _, _]
93 | name == program && flags == never ->
94 return Can.NoFlags
96 | name == program ->
97 return (Can.Flags flags)
98 <* Effects.checkPortType makeError flags
100 _ ->
101 Result.throw region (Error.BadMain mainType)
102 in
103 do kind <- getMainKind
104 let newBody = A.A undefined (Can.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")