git.iko.soy/elk
on edd4fbb help sign in
elk/compiler/Type/ExtraChecks.hs
145 lines 6.3 kB history raw
1{-# OPTIONS_GHC -W #-}
2module Type.ExtraChecks (mainType, occurs, portTypes) where
3-- This module contains checks to be run *after* type inference has
4-- completed successfully. At that point we still need to do occurs
5-- checks and ensure that `main` has an acceptable type.
7import Control.Applicative ((<$>),(<*>))
8import Control.Monad.State
9import qualified Data.List as List
10import qualified Data.Map as Map
11import qualified Data.UnionFind.IO as UF
12import Type.Type ( Variable, structure, Term1(..), toSrcType )
13import qualified Type.State as TS
14import qualified Type.Alias as Alias
15import Text.PrettyPrint as P
16import SourceSyntax.PrettyPrint (pretty)
17import qualified SourceSyntax.Type as T
18import qualified SourceSyntax.Expression as E
19import qualified SourceSyntax.Location as L
20import qualified Transform.Expression as Expr
21import qualified Data.Traversable as Traverse
22import System.IO.Unsafe
24throw err = Left [ P.vcat err ]
26mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String T.Type))
27mainType rules env = mainCheck rules <$> Traverse.traverse toSrcType env
28 where
29 mainCheck :: Alias.Rules -> Map.Map String T.Type -> Either [P.Doc] (Map.Map String T.Type)
30 mainCheck rules env =
31 case Map.lookup "main" env of
32 Nothing -> Right env
33 Just mainType
34 | tipe `elem` acceptable -> Right env
35 | otherwise -> throw err
36 where
37 acceptable = [ "Graphics.Element.Element"
38 , "Signal.Signal Graphics.Element.Element" ]
40 tipe = P.render . pretty $ Alias.canonicalRealias (fst rules) mainType
41 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
42 , P.text "Instead 'main' has type:\n"
43 , P.nest 4 . pretty $ Alias.realias rules mainType
44 , P.text " " ]
46portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
47portTypes rules expr =
48 const () <$> Expr.checkPorts checkIn checkOut expr
49 where
50 showType tipe = (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
52 checkIn name st tt =
53 do t <- getSignal name st
54 case unsafePerformIO (toSrcType tt) of
55 T.Lambda a b ->
56 do isJsType "coming in" name a
57 if b `elem` okayTypes then return () else throw msg
58 where
59 okayTypes = [ t
60 , T.Data "Maybe.Maybe" [t]
61 , T.Data "Either.Either" [T.Data "String.String" [], t]
62 ]
63 msg = [ P.text $ "Type Error: the handler for port '" ++ name ++
64 "' returns values of type:\n"
65 , showType b
66 , P.text $ "but the port's type annotation requires that the handler returns values"
67 , P.text $ "with one of the following types:\n"
68 ] ++ map showType okayTypes ++
69 [ P.text "If the handler returns a Maybe or Either, invalid values will cause an"
70 , P.text "error to be thrown to the JS error handler associated with this port." ]
72 tipe ->
73 throw [ P.text $ "Type Error: the handler for port '" ++ name ++
74 "' must be a function!"
75 , P.text "Instead it was given a value of type:\n"
76 , showType tipe
77 ]
79 checkOut name st =
80 do t <- getSignal name st
81 isJsType "sent out" name t
83 getSignal name tipe =
84 case tipe of
85 T.Data "Signal.Signal" [t] -> return t
86 _ -> throw [ P.text $ "Type Error: port '" ++ name ++ "' must be a Signal,"
87 , P.text $ "but the type annotation says it has non-Signal type:\n"
88 , showType tipe
89 , P.text $ "Maybe instead you want the following type?\n"
90 , showType (T.Data "Signal.Signal" [tipe])
91 ]
93 isJsType msg name tipe =
94 case tipe of
95 T.Data ctor ts | okay ctor -> mapM_ (isJsType msg name) ts
96 | otherwise -> throw $ err msg "Elm values"
97 T.Var _ -> throw $ err msg "type variables"
98 T.Lambda _ _ -> throw $ err msg "Elm functions"
99 T.EmptyRecord -> throw $ err msg "Elm records"
100 T.Record _ _ -> throw $ err msg "Elm records"
101 where
102 okay ctor = and [ List.isPrefixOf "JavaScript." ctor
103 , 1 == length (filter (=='.') ctor) ]
105 err msg kind =
106 [ P.text $ "Type Error: the values " ++ msg ++ " through port '" ++ name ++
107 "' must be JavaScript values."
108 , P.text $ "The values sent through this port contain " ++ kind ++ " with type:\n"
109 , showType tipe
110 ]
112occurs :: (String, Variable) -> StateT TS.SolverState IO ()
113occurs (name, variable) =
114 do vars <- liftIO $ infiniteVars [] variable
115 case vars of
116 [] -> return ()
117 var:_ -> do
118 desc <- liftIO $ UF.descriptor var
119 case structure desc of
120 Nothing ->
121 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
122 Just _ ->
123 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
124 var' <- liftIO $ UF.fresh desc
125 TS.addError (L.NoSpan name) (Just msg) var var'
126 where
127 msg = "Infinite types are not allowed"
128 fallback _ = return $ P.text msg
130 infiniteVars :: [Variable] -> Variable -> IO [Variable]
131 infiniteVars seen var =
132 let go = infiniteVars (var:seen) in
133 if var `elem` seen
134 then return [var]
135 else do
136 desc <- UF.descriptor var
137 case structure desc of
138 Nothing -> return []
139 Just struct ->
140 case struct of
141 App1 a b -> (++) <$> go a <*> go b
142 Fun1 a b -> (++) <$> go a <*> go b
143 Var1 a -> go a
144 EmptyRecord1 -> return []
145 Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))