git.iko.soy/elk
on bb35d68 help sign in
elk/src/Nitpick/TopLevelTypes.hs
127 lines 2.9 kB history raw
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Nitpick.TopLevelTypes (topLevelTypes) where
5import qualified Data.Foldable as F
6import Data.Map ((!))
7import qualified Data.Map as Map
8import Data.Text (Text)
10import qualified AST.Expression.Canonical as Can
11import qualified AST.Module.Name as ModuleName
12import qualified AST.Pattern as P
13import qualified AST.Type as Type
14import qualified AST.Variable as Var
15import qualified Canonicalize.Effects as Effects
16import qualified Elm.Package as Pkg
17import qualified Reporting.Annotation as A
18import qualified Reporting.Error.Type as Error
19import qualified Reporting.Result as Result
20import qualified Reporting.Warning as Warning
24type Result =
25 Result.Result () Warning.Warning Error.Error
28type TypeDict =
29 Map.Map Text Type.Canonical
33-- CHECK TOP LEVEL TYPES
36topLevelTypes :: TypeDict -> Can.SortedDefs -> Result [Can.Def]
37topLevelTypes typeEnv sortedDefs =
38 let
39 check =
40 checkAnnotation typeEnv
41 in
42 case sortedDefs of
43 Can.NoMain defs ->
44 pure defs
45 <* F.traverse_ check defs
47 Can.YesMain before main after ->
48 do check main
49 <* F.traverse_ check before
50 <* F.traverse_ check after
52 mainDef <- checkMain typeEnv main
54 return (before ++ mainDef : after)
58-- MISSING ANNOTATIONS
61checkAnnotation :: TypeDict -> Can.Def -> Result ()
62checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =
63 case (pattern, maybeType) of
64 (P.Var name, Nothing) ->
65 let
66 warning =
67 Warning.MissingTypeAnnotation name (typeEnv ! name)
68 in
69 Result.warn region warning ()
71 _ ->
72 return ()
76-- CHECK MAIN TYPE
79checkMain :: TypeDict -> Can.Def -> Result Can.Def
80checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
81 let
82 mainType =
83 typeEnv ! "main"
85 makeError tipe maybeMsg =
86 A.A region (Error.BadFlags tipe maybeMsg)
88 getMainKind =
89 case Type.deepDealias mainType of
90 Type.App name [_]
91 | name == vdomNode ->
92 return Can.VDom
94 Type.App name [flags, _, _]
95 | name == program && flags == never ->
96 return Can.NoFlags
98 | name == program ->
99 return (Can.Flags flags)
100 <* Effects.checkPortType makeError flags
102 _ ->
103 Result.throw region (Error.BadMain mainType)
104 in
105 do kind <- getMainKind
106 let newBody = A.A undefined (Can.Program kind body)
107 return (Can.Def facts pattern newBody maybeType)
110program :: Type.Canonical
111program =
112 Type.Type (Var.inCore "Platform" "Program")
115never :: Type.Canonical
116never =
117 Type.Type (Var.inCore "Basics" "Never")
120vdomNode :: Type.Canonical
121vdomNode =
122 let
123 vdom =
124 ModuleName.Canonical Pkg.virtualDom "VirtualDom"
125 in
126 Type.Type (Var.fromModule vdom "Node")