git.iko.soy/elk
on b09bb00 help sign in
elk/src/Nitpick/TopLevelTypes.hs
128 lines 3.0 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 qualified Data.Text as Text
9import Data.Text (Text)
11import qualified AST.Expression.Canonical as Can
12import qualified AST.Module.Name as ModuleName
13import qualified AST.Pattern as P
14import qualified AST.Type as Type
15import qualified AST.Variable as Var
16import qualified Canonicalize.Effects as Effects
17import qualified Elm.Package as Pkg
18import qualified Reporting.Annotation as A
19import qualified Reporting.Error.Type as Error
20import qualified Reporting.Result as Result
21import qualified Reporting.Warning as Warning
25type Result =
26 Result.Result () Warning.Warning Error.Error
29type TypeDict =
30 Map.Map Text Type.Canonical
34-- CHECK TOP LEVEL TYPES
37topLevelTypes :: TypeDict -> Can.SortedDefs -> Result [Can.Def]
38topLevelTypes typeEnv sortedDefs =
39 let
40 check =
41 checkAnnotation typeEnv
42 in
43 case sortedDefs of
44 Can.NoMain defs ->
45 pure defs
46 <* F.traverse_ check defs
48 Can.YesMain before main after ->
49 do check main
50 <* F.traverse_ check before
51 <* F.traverse_ check after
53 mainDef <- checkMain typeEnv main
55 return (before ++ mainDef : after)
59-- MISSING ANNOTATIONS
62checkAnnotation :: TypeDict -> Can.Def -> Result ()
63checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =
64 case (pattern, maybeType) of
65 (P.Var name, Nothing) ->
66 let
67 warning =
68 Warning.MissingTypeAnnotation (Text.unpack name) (typeEnv ! name)
69 in
70 Result.warn region warning ()
72 _ ->
73 return ()
77-- CHECK MAIN TYPE
80checkMain :: TypeDict -> Can.Def -> Result Can.Def
81checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =
82 let
83 mainType =
84 typeEnv ! "main"
86 makeError tipe maybeMsg =
87 A.A region (Error.BadFlags tipe maybeMsg)
89 getMainKind =
90 case Type.deepDealias mainType of
91 Type.App name [_]
92 | name == vdomNode ->
93 return Can.VDom
95 Type.App name [flags, _, _]
96 | name == program && flags == never ->
97 return Can.NoFlags
99 | name == program ->
100 return (Can.Flags flags)
101 <* Effects.checkPortType makeError flags
103 _ ->
104 Result.throw region (Error.BadMain mainType)
105 in
106 do kind <- getMainKind
107 let newBody = A.A undefined (Can.Program kind body)
108 return (Can.Def facts pattern newBody maybeType)
111program :: Type.Canonical
112program =
113 Type.Type (Var.inCore "Platform" "Program")
116never :: Type.Canonical
117never =
118 Type.Type (Var.inCore "Basics" "Never")
121vdomNode :: Type.Canonical
122vdomNode =
123 let
124 vdom =
125 ModuleName.Canonical Pkg.virtualDom "VirtualDom"
126 in
127 Type.Type (Var.fromModule vdom "Node")