git.iko.soy/elk
on 8a87749 help sign in
elk/src/Type/ExtraChecks.hs
160 lines 4.6 kB history raw
1{-# OPTIONS_GHC -Wall #-}
3{-| This module contains checks to be run *after* type inference has completed
4successfully. At that point we still need to do occurs checks and ensure that
5`main` has an acceptable type.
6-}
7module Type.ExtraChecks (effectTypes, occurs) where
9import Prelude hiding (maybe)
10import Control.Applicative ((<$>),(<*>))
11import Control.Monad.Error
12import Control.Monad.State
13import qualified Data.Map as Map
14import qualified Data.Traversable as Traverse
15import qualified Data.UnionFind.IO as UF
16import Text.PrettyPrint as P
18import qualified AST.Annotation as A
19import qualified AST.PrettyPrint as PP
20import qualified AST.Type as ST
21import qualified AST.Variable as Var
22import qualified Type.Hint as Hint
23import qualified Type.Type as TT
24import qualified Type.State as TS
27-- EFFECT TYPE CHECKS
29effectTypes :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
30effectTypes environment =
31 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32 mainCheck environment'
33 return environment'
36-- MAIN TYPE
38mainCheck
39 :: (Monad m)
40 => Map.Map String ST.CanonicalType
41 -> ErrorT [P.Doc] m ()
42mainCheck env =
43 case Map.lookup "main" env of
44 Nothing ->
45 return ()
47 Just typeOfMain ->
48 let tipe = ST.deepDealias typeOfMain
49 in
50 if tipe `elem` validMainTypes
51 then return ()
52 else throwError [ badMainMessage typeOfMain ]
55validMainTypes :: [ST.CanonicalType]
56validMainTypes =
57 [ element
58 , html
59 , signal element
60 , signal html
61 ]
62 where
63 fromModule :: [String] -> String -> ST.CanonicalType
64 fromModule home name =
65 ST.Type (Var.fromModule home name)
67 html =
68 fromModule ["VirtualDom"] "Node"
70 signal tipe =
71 ST.App (fromModule ["SignalTypes"] "Signal") [ tipe ]
73 element =
74 let builtin name =
75 ST.Type (Var.builtin name)
77 maybe tipe =
78 ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]
79 in
80 ST.Record
81 [ ("element", fromModule ["Graphics","Element"] "ElementPrim")
82 , ("props",
83 ST.Record
84 [ ("click" , builtin "_Tuple0")
85 , ("color" , maybe (fromModule ["Color"] "Color"))
86 , ("height" , builtin "Int")
87 , ("hover" , builtin "_Tuple0")
88 , ("href" , builtin "String")
89 , ("id" , builtin "Int")
90 , ("opacity", builtin "Float")
91 , ("tag" , builtin "String")
92 , ("width" , builtin "Int")
93 ]
94 Nothing
95 )
96 ]
97 Nothing
100badMainMessage :: ST.CanonicalType -> P.Doc
101badMainMessage typeOfMain =
102 P.vcat
103 [ P.text "Type Error: 'main' must have one of the following types:"
104 , P.text " "
105 , P.text " Element, Html, Signal Element, Signal Html"
106 , P.text " "
107 , P.text "Instead 'main' has type:\n"
108 , P.nest 4 (PP.pretty typeOfMain)
109 , P.text " "
110 ]
113-- INFINITE TYPES
115occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
116occurs (name, variable) =
117 do vars <- liftIO $ infiniteVars [] variable
118 case vars of
119 [] ->
120 return ()
122 var : _ ->
123 do desc <- liftIO $ UF.descriptor var
124 case TT.structure desc of
125 Nothing ->
126 TS.addHint (P.text msg)
128 Just _ ->
129 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
130 var' <- liftIO $ UF.fresh desc
131 hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
132 TS.addHint hint
133 where
134 msg = "Infinite types are not allowed"
136 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
137 infiniteVars seen var =
138 let go = infiniteVars (var:seen) in
139 if var `elem` seen
140 then return [var]
141 else do
142 desc <- UF.descriptor var
143 case TT.structure desc of
144 Nothing -> return []
145 Just struct ->
146 case struct of
147 TT.App1 a b ->
148 (++) <$> go a <*> go b
150 TT.Fun1 a b ->
151 (++) <$> go a <*> go b
153 TT.Var1 a ->
154 go a
156 TT.EmptyRecord1 ->
157 return []
159 TT.Record1 fields ext ->
160 concat <$> mapM go (ext : concat (Map.elems fields))