git.iko.soy/elk
on 63243ca help sign in
elk/compiler/Type/ExtraChecks.hs
132 lines 5.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.Helpers as Help
18import qualified SourceSyntax.Type as T
19import qualified SourceSyntax.Expression as E
20import qualified SourceSyntax.Location as L
21import qualified Transform.Expression as Expr
22import qualified Data.Traversable as Traverse
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 " " ]
46data Direction = In | Out
48portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()
49portTypes rules expr =
50 const () <$> Expr.checkPorts (check In) (check Out) expr
51 where
52 check = isValid True
53 isValid firstOrder direction name tipe =
54 let valid = isValid firstOrder direction name in
55 case tipe of
56 T.Data ctor ts | okay ctor -> mapM_ valid ts
57 | otherwise -> err "Algebraic Data Types"
59 T.Var _ -> err "free type variables"
61 T.Lambda t1 t2 ->
62 case direction of
63 In -> err "functions"
64 Out | firstOrder -> do isValid False direction name t1
65 valid t2
66 | otherwise -> err "higher-order functions"
68 T.Record _ (Just _) -> err "extended records with free type variables"
70 T.Record fields Nothing ->
71 mapM_ (\(k,v) -> (,) k <$> valid v) fields
73 where
74 okay ctor = isJs ctor || isElm ctor
76 isJs ctor =
77 List.isPrefixOf "JavaScript." ctor
78 && length (filter (=='.') ctor) == 1
80 isElm ctor =
81 ctor `elem` ["Int","Float","String","Bool","Maybe.Maybe","_List","Signal.Signal"]
82 || Help.isTuple ctor
84 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }
85 txt = P.text . concat
87 err kind =
88 throw $
89 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
90 , " through port '", name, "' is invalid." ]
91 , txt [ "Acceptable values for ", dir "incoming" "outgoing"
92 , " ports include JavaScript values and the following Elm values:" ]
93 , txt [ "Ints, Floats, Bools, Strings, Maybes, Lists, Tuples, "
94 , dir "" "first-order functions, ", "and concrete records." ]
95 , txt [ "The values sent through this port contain ", kind, ":\n" ]
96 , (P.nest 4 . pretty $ Alias.realias rules tipe) <> P.text "\n"
97 ]
99occurs :: (String, Variable) -> StateT TS.SolverState IO ()
100occurs (name, variable) =
101 do vars <- liftIO $ infiniteVars [] variable
102 case vars of
103 [] -> return ()
104 var:_ -> do
105 desc <- liftIO $ UF.descriptor var
106 case structure desc of
107 Nothing ->
108 modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
109 Just _ ->
110 do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
111 var' <- liftIO $ UF.fresh desc
112 TS.addError (L.NoSpan name) (Just msg) var var'
113 where
114 msg = "Infinite types are not allowed"
115 fallback _ = return $ P.text msg
117 infiniteVars :: [Variable] -> Variable -> IO [Variable]
118 infiniteVars seen var =
119 let go = infiniteVars (var:seen) in
120 if var `elem` seen
121 then return [var]
122 else do
123 desc <- UF.descriptor var
124 case structure desc of
125 Nothing -> return []
126 Just struct ->
127 case struct of
128 App1 a b -> (++) <$> go a <*> go b
129 Fun1 a b -> (++) <$> go a <*> go b
130 Var1 a -> go a
131 EmptyRecord1 -> return []
132 Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))