git.iko.soy/elk
on 552becc help sign in
elk/src/Type/ExtraChecks.hs
157 lines 4.5 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 (mainType, 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-- MAIN TYPE
29mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)
30mainType environment =
31 do environment' <- liftIO $ Traverse.traverse TT.toSrcType environment
32 mainCheck environment'
35mainCheck
36 :: (Monad m)
37 => Map.Map String ST.CanonicalType
38 -> ErrorT [P.Doc] m (Map.Map String ST.CanonicalType)
39mainCheck env =
40 case Map.lookup "main" env of
41 Nothing ->
42 return env
44 Just typeOfMain ->
45 let tipe = ST.deepDealias typeOfMain
46 in
47 if tipe `elem` validMainTypes
48 then return env
49 else throwError [ badMainMessage typeOfMain ]
52validMainTypes :: [ST.CanonicalType]
53validMainTypes =
54 [ element
55 , html
56 , varying element
57 , varying html
58 ]
59 where
60 fromModule :: [String] -> String -> ST.CanonicalType
61 fromModule home name =
62 ST.Type (Var.fromModule home name)
64 html =
65 fromModule ["VirtualDom"] "Node"
67 varying tipe =
68 ST.App (fromModule ["Signal"] "Varying") [ tipe ]
70 element =
71 let builtin name =
72 ST.Type (Var.builtin name)
74 maybe tipe =
75 ST.App (fromModule ["Maybe"] "Maybe") [ tipe ]
76 in
77 ST.Record
78 [ ("element", fromModule ["Graphics","Element"] "ElementPrim")
79 , ("props",
80 ST.Record
81 [ ("click" , builtin "_Tuple0")
82 , ("color" , maybe (fromModule ["Color"] "Color"))
83 , ("height" , builtin "Int")
84 , ("hover" , builtin "_Tuple0")
85 , ("href" , builtin "String")
86 , ("id" , builtin "Int")
87 , ("opacity", builtin "Float")
88 , ("tag" , builtin "String")
89 , ("width" , builtin "Int")
90 ]
91 Nothing
92 )
93 ]
94 Nothing
97badMainMessage :: ST.CanonicalType -> P.Doc
98badMainMessage typeOfMain =
99 P.vcat
100 [ P.text "Type Error: 'main' must have one of the following types:"
101 , P.text " "
102 , P.text " Element, Html, Varying Element, Varying Html"
103 , P.text " "
104 , P.text "Instead 'main' has type:\n"
105 , P.nest 4 (PP.pretty typeOfMain)
106 , P.text " "
107 ]
110-- INFINITE TYPES
112occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()
113occurs (name, variable) =
114 do vars <- liftIO $ infiniteVars [] variable
115 case vars of
116 [] ->
117 return ()
119 var : _ ->
120 do desc <- liftIO $ UF.descriptor var
121 case TT.structure desc of
122 Nothing ->
123 TS.addHint (P.text msg)
125 Just _ ->
126 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
127 var' <- liftIO $ UF.fresh desc
128 hint <- liftIO $ Hint.create (A.None (P.text name)) (Just msg) var var'
129 TS.addHint hint
130 where
131 msg = "Infinite types are not allowed"
133 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
134 infiniteVars seen var =
135 let go = infiniteVars (var:seen) in
136 if var `elem` seen
137 then return [var]
138 else do
139 desc <- UF.descriptor var
140 case TT.structure desc of
141 Nothing -> return []
142 Just struct ->
143 case struct of
144 TT.App1 a b ->
145 (++) <$> go a <*> go b
147 TT.Fun1 a b ->
148 (++) <$> go a <*> go b
150 TT.Var1 a ->
151 go a
153 TT.EmptyRecord1 ->
154 return []
156 TT.Record1 fields ext ->
157 concat <$> mapM go (ext : concat (Map.elems fields))