git.iko.soy/elk
on master help sign in
Remove the Type.Alias module
07907a0Evan Czaplicki
Elm.cabal−2
compare with master
unifiedsplit
@@ -78,7 +78,6 @@ Library
78 Parse.Parse,
78 Parse.Parse,
79 Parse.Pattern,
79 Parse.Pattern,
80 Parse.Type,
80 Parse.Type,
81− Type.Alias,
82 Type.Constrain.Expression,
81 Type.Constrain.Expression,
83 Type.Constrain.Literal,
82 Type.Constrain.Literal,
84 Type.Constrain.Pattern,
83 Type.Constrain.Pattern,
@@ -170,7 +169,6 @@ Executable elm
170 Parse.Parse,
169 Parse.Parse,
171 Parse.Pattern,
170 Parse.Pattern,
172 Parse.Type,
171 Parse.Type,
173− Type.Alias,
174 Type.Constrain.Expression,
172 Type.Constrain.Expression,
175 Type.Constrain.Literal,
173 Type.Constrain.Literal,
176 Type.Constrain.Pattern,
174 Type.Constrain.Pattern,
compiler/Build/Print.hs+1−4
@@ -7,7 +7,6 @@ import qualified Data.Map as Map
7import qualified Data.List as List
7import qualified Data.List as List
8import qualified AST.Module as M
8import qualified AST.Module as M
9import qualified AST.PrettyPrint as Pretty
9import qualified AST.PrettyPrint as Pretty
10−import qualified Type.Alias as Alias
11import qualified Text.PrettyPrint as P
10import qualified Text.PrettyPrint as P
12
11
13moduleTypes :: Map.Map String M.Interface -> M.CanonicalModule -> IO ()
12moduleTypes :: Map.Map String M.Interface -> M.CanonicalModule -> IO ()
@@ -25,12 +24,10 @@ types interfaces types' aliases imports =
25 mapM_ printType (Map.toList types')
24 mapM_ printType (Map.toList types')
26 putStrLn ""
25 putStrLn ""
27 where
26 where
28− rules = Alias.rules interfaces aliases imports
29−
30 printType (n,t) = do
27 printType (n,t) = do
31 print $ P.hsep [ Pretty.variable n
28 print $ P.hsep [ Pretty.variable n
32 , P.text ":"
29 , P.text ":"
33− , Pretty.pretty (Alias.realias rules t) ]
30+ , Pretty.pretty t ]
34
31
35errors :: [P.Doc] -> IO ()
32errors :: [P.Doc] -> IO ()
36errors errs =
33errors errs =
compiler/Type/Alias.hsdeleted−148
@@ -1,148 +0,0 @@
1−{-# OPTIONS_GHC -W #-}
2−module Type.Alias (realias, rules, canonicalRealias, Rules) where
3−
4−import Control.Applicative ((<$>),(<*>))
5−import Control.Monad
6−import Control.Arrow (second)
7−import Data.Map ((!))
8−import qualified Data.Map as Map
9−import qualified Data.List as List
10−import AST.Type
11−import AST.Module
12−
13−type Rules = (Aliases, CanonicalType -> CanonicalType)
14−
15−rules interfaces moduleAliases moduleImports = (Map.empty, id)
16− --(error "Type.Alias.rules is not defined")
17− --(collect interfaces moduleAliases, localizer moduleImports)
18−{--
19−collect interfaces moduleAliases =
20− filter (not . isPrimitive) rawAliases
21− where
22− rawAliases =
23− moduleAliases ++ concatMap iAliases (Map.elems interfaces)
24−
25− isPrimitive (_,_,tipe) =
26− case tipe of
27− Data _ [] -> True
28− _ -> False
29−--}
30−{--
31−localizer moduleImports = go
32− where
33− go tipe =
34− case tipe of
35− Var _ -> tipe
36− Lambda t1 t2 -> Lambda (go t1) (go t2)
37− Data name ts -> Data (localize name) (map go ts)
38− Record fs ext -> Record (map (second go) fs) ext
39−
40− byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)
41− Map.empty moduleImports
42−
43− separate name =
44− case List.elemIndices '.' name of
45− [] -> ("",name)
46− is -> let i = last is in
47− (take i name, drop (i+1) name)
48−
49− shortest = List.minimumBy (\a b -> compare (length a) (length b))
50−
51− localize name = shortest (name : concatMap (localize' value) methods)
52− where (modul, value) = separate name
53− methods = Map.findWithDefault [] modul byMethod
54−
55− localize' name method =
56− case method of
57− As modul -> [modul ++ "." ++ name]
58− Hiding xs | name `notElem` xs -> [name]
59− Importing xs | name `elem` xs -> [name]
60− _ -> []
61−--}
62−realias :: Rules -> CanonicalType -> CanonicalType
63−realias (aliases,localize) tipe = tipe
64− -- (error "Type.Alias.realias is not defined")
65− -- localize (canonicalRealias aliases tipe)
66−
67−-- Realias using canonical aliases, so results will have aliases
68−-- that are fully qualified and possible to compare.
69−canonicalRealias :: Aliases -> CanonicalType -> CanonicalType
70−canonicalRealias aliases tipe = tipe
71−-- (error "Type.Alias.rules is not defined")
72−{--
73− case concatMap tryRealias aliases of
74− [] -> if tipe == tipe' then tipe else f tipe'
75− tipes -> f (bestType tipes)
76− where
77− tryRealias (name, args, aliasTipe) =
78− case diff aliasTipe tipe of
79− Nothing -> []
80− Just kvs ->
81− let holes = collectFields kvs
82− hasArgs = List.sort args == Map.keys holes
83− isConsistent = all allEqual (Map.elems holes)
84− in case hasArgs && isConsistent of
85− False -> []
86− True -> [Data name $ map (\arg -> head (holes ! arg)) args]
87−
88− f = canonicalRealias aliases
89− tipe' =
90− case tipe of
91− Var _ -> tipe
92− Lambda t1 t2 -> Lambda (f t1) (f t2)
93− Data name ts -> Data name (map f ts)
94− Record fs ext -> Record (map (second f) fs) ext
95−--}
96−
97−allEqual [] = True
98−allEqual (x:xs) = all (==x) xs
99−
100−{--
101−bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs
102− where
103− pairs :: [(Type,Int)]
104− pairs = zip tipes (map numFields tipes)
105−
106− numFields :: Type -> Int
107− numFields tipe =
108− case tipe of
109− Lambda t1 t2 -> numFields t1 + numFields t2
110− Var _ -> 0
111− Data _ ts -> sum (map numFields ts)
112− Record fields _ -> length fields + sum (map (numFields . snd) fields)
113−
114−diff :: CanonicalType -> CanonicalType -> Maybe [(String,CanonicalType)]
115−diff general specific =
116− case (general, specific) of
117− (Lambda g1 g2, Lambda s1 s2) -> (++) <$> diff g1 s1 <*> diff g2 s2
118− (Var x, t) -> Just [(x,t)]
119− (Data gname gts, Data sname sts)
120− | gname == sname && length gts == length sts ->
121− concat <$> zipWithM diff gts sts
122− (Record [] Nothing, Record [] Nothing) -> Just []
123− (Record _ _, Record [] Nothing) -> Nothing
124− (Record [] Nothing, Record _ _) -> Nothing
125− (Record gfs gext, Record sfs sext) ->
126− let gfields = collectFields gfs
127− sfields = collectFields sfs
128−
129− overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields
130− isAligned = Map.size gfields == Map.size overlap && and (Map.elems overlap)
131− in
132− case isAligned of
133− False -> Nothing
134− True -> let remaining = Map.difference sfields gfields
135− sext' = case sext of
136− Just x | Map.null remaining -> Var x
137− _ -> Record (flattenFields remaining) sext
138− gext' = maybe (Record [] Nothing) Var gext
139− matchMap = Map.intersectionWith (zipWith diff) gfields sfields
140− in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))
141− (_,_) -> Nothing
142−
143−collectFields fields =
144− foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields
145−
146−flattenFields fields =
147− concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)
148−--}
compiler/Type/ExtraChecks.hs+12−14
@@ -21,17 +21,16 @@ import qualified AST.Variable as V
21import qualified Transform.Expression as Expr
21import qualified Transform.Expression as Expr
22import qualified Type.Type as TT
22import qualified Type.Type as TT
23import qualified Type.State as TS
23import qualified Type.State as TS
24−import qualified Type.Alias as Alias
25
24
26throw :: [Doc] -> Either [Doc] a
25throw :: [Doc] -> Either [Doc] a
27throw err = Left [ P.vcat err ]
26throw err = Left [ P.vcat err ]
28
27
29−mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.CanonicalType))
28+mainType :: TS.Env -> IO (Either [P.Doc] (Map.Map String ST.CanonicalType))
30−mainType aliasRules environment =
29+mainType environment =
31− mainCheck aliasRules <$> Traverse.traverse TT.toSrcType environment
30+ mainCheck <$> Traverse.traverse TT.toSrcType environment
32 where
31 where
33− mainCheck :: Alias.Rules -> Map.Map String ST.CanonicalType -> Either [P.Doc] (Map.Map String ST.CanonicalType)
32+ mainCheck :: Map.Map String ST.CanonicalType -> Either [P.Doc] (Map.Map String ST.CanonicalType)
34− mainCheck rules env =
33+ mainCheck env =
35 case Map.lookup "main" env of
34 case Map.lookup "main" env of
36 Nothing -> Right env
35 Nothing -> Right env
37 Just typeOfMain
36 Just typeOfMain
@@ -41,16 +40,16 @@ mainType aliasRules environment =
41 acceptable = [ "Graphics.Element.Element"
40 acceptable = [ "Graphics.Element.Element"
42 , "Signal.Signal Graphics.Element.Element" ]
41 , "Signal.Signal Graphics.Element.Element" ]
43
42
44− tipe = PP.renderPretty $ Alias.canonicalRealias (fst rules) typeOfMain
43+ tipe = PP.renderPretty typeOfMain
45 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
44 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."
46 , P.text "Instead 'main' has type:\n"
45 , P.text "Instead 'main' has type:\n"
47− , P.nest 4 . PP.pretty $ Alias.realias rules typeOfMain
46+ , P.nest 4 (PP.pretty typeOfMain)
48 , P.text " " ]
47 , P.text " " ]
49
48
50data Direction = In | Out
49data Direction = In | Out
51
50
52−portTypes :: Alias.Rules -> Canonical.Expr -> Either [P.Doc] ()
51+portTypes :: Canonical.Expr -> Either [P.Doc] ()
53−portTypes rules expr =
52+portTypes expr =
54 const () <$> Expr.checkPorts (check In) (check Out) expr
53 const () <$> Expr.checkPorts (check In) (check Out) expr
55 where
54 where
56 check = isValid True False False
55 check = isValid True False False
@@ -111,7 +110,7 @@ portTypes rules expr =
111 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
110 [ txt [ "Type Error: the value ", dir "coming in" "sent out"
112 , " through port '", name, "' is invalid." ]
111 , " through port '", name, "' is invalid." ]
113 , txt [ "It contains ", kind, ":\n" ]
112 , txt [ "It contains ", kind, ":\n" ]
114− , (P.nest 4 . PP.pretty $ Alias.realias rules tipe) <> P.text "\n"
113+ , P.nest 4 (PP.pretty tipe) <> P.text "\n"
115 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
114 , txt [ "Acceptable values for ", dir "incoming" "outgoing", " ports include:" ]
116 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples," ]
115 , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples," ]
117 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
116 , txt [ " Json.Values, ", dir "" "first-order functions, ", "and concrete records." ]
@@ -131,17 +130,16 @@ occurs (name, variable) =
131 desc <- liftIO $ UF.descriptor var
130 desc <- liftIO $ UF.descriptor var
132 case TT.structure desc of
131 case TT.structure desc of
133 Nothing ->
132 Nothing ->
134− modify $ \s -> s { TS.sErrors = fallback : TS.sErrors s }
133+ modify $ \s -> s { TS.sErrors = P.text msg : TS.sErrors s }
135 Just _ ->
134 Just _ ->
136 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
135 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })
137 var' <- liftIO $ UF.fresh desc
136 var' <- liftIO $ UF.fresh desc
138 TS.addError (A.None (P.text name)) (Just msg) var var'
137 TS.addError (A.None (P.text name)) (Just msg) var var'
139 where
138 where
140 msg = "Infinite types are not allowed"
139 msg = "Infinite types are not allowed"
141− fallback _ = return $ P.text msg
142
140
143 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
141 infiniteVars :: [TT.Variable] -> TT.Variable -> IO [TT.Variable]
144− infiniteVars seen var =
142+ infiniteVars seen var =
145 let go = infiniteVars (var:seen) in
143 let go = infiniteVars (var:seen) in
146 if var `elem` seen
144 if var `elem` seen
147 then return [var]
145 then return [var]
compiler/Type/Inference.hs+3−5
@@ -18,7 +18,6 @@ import qualified Type.ExtraChecks as Check
18import Control.Arrow (first, second)
18import Control.Arrow (first, second)
19import Control.Monad.State (execStateT, forM)
19import Control.Monad.State (execStateT, forM)
20import Control.Monad.Error (ErrorT, runErrorT, liftIO)
20import Control.Monad.Error (ErrorT, runErrorT, liftIO)
21−import qualified Type.Alias as Alias
22
21
23import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
22import System.IO.Unsafe -- Possible to switch over to the ST monad instead of
24 -- the IO monad. I don't think that'd be worthwhile.
23 -- the IO monad. I don't think that'd be worthwhile.
@@ -49,12 +48,11 @@ infer interfaces modul = unsafePerformIO $ do
49 Left err -> return $ Left err
48 Left err -> return $ Left err
50 Right (header, constraint) -> do
49 Right (header, constraint) -> do
51 state <- execStateT (Solve.solve constraint) TS.initialState
50 state <- execStateT (Solve.solve constraint) TS.initialState
52− let rules = Alias.rules interfaces (aliases moduleBody) (imports modul)
53 case TS.sErrors state of
51 case TS.sErrors state of
54− errors@(_:_) -> Left `fmap` sequence (map ($ rules) (reverse errors))
52+ errors@(_:_) -> return (Left errors)
55− [] -> case Check.portTypes rules (program moduleBody) of
53+ [] -> case Check.portTypes (program moduleBody) of
56 Left err -> return (Left err)
54 Left err -> return (Left err)
57− Right () -> Check.mainType rules types
55+ Right () -> Check.mainType types
58 where
56 where
59 header' = Map.delete "::" header
57 header' = Map.delete "::" header
60 types = Map.difference (TS.sSavedEnv state) header'
58 types = Map.difference (TS.sSavedEnv state) header'
compiler/Type/State.hs+8−7
@@ -10,7 +10,6 @@ import qualified Data.UnionFind.IO as UF
10import qualified AST.Annotation as A
10import qualified AST.Annotation as A
11import AST.PrettyPrint
11import AST.PrettyPrint
12import Text.PrettyPrint as P
12import Text.PrettyPrint as P
13−import qualified Type.Alias as Alias
14import Type.Type
13import Type.Type
15
14
16-- Pool
15-- Pool
@@ -33,7 +32,7 @@ data SolverState = SS {
33 sSavedEnv :: Env,
32 sSavedEnv :: Env,
34 sPool :: Pool,
33 sPool :: Pool,
35 sMark :: Int,
34 sMark :: Int,
36− sErrors :: [Alias.Rules -> IO P.Doc]
35+ sErrors :: [P.Doc]
37}
36}
38
37
39initialState = SS {
38initialState = SS {
@@ -47,13 +46,15 @@ initialState = SS {
47modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
46modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
48modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
47modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
49
48
49+addError :: A.Region -> Maybe String -> UF.Point Descriptor -> UF.Point Descriptor
50+ -> StateT SolverState IO ()
50addError region hint t1 t2 =
51addError region hint t1 t2 =
52+ do err <- liftIO makeError
51− modify $ \state -> state { sErrors = makeError : sErrors state }
53+ modify $ \state -> state { sErrors = err : sErrors state }
52 where
54 where
53− makeError rules = do
55+ makeError = do
54− let prettiest = pretty . Alias.realias rules
55− t1' <- prettiest <$> toSrcType t1
56+ t1' <- pretty <$> toSrcType t1
56− t2' <- prettiest <$> toSrcType t2
57+ t2' <- pretty <$> toSrcType t2
57 return . P.vcat $
58 return . P.vcat $
58 [ P.text "Type error" <+> pretty region <> P.colon
59 [ P.text "Type error" <+> pretty region <> P.colon
59 , maybe P.empty P.text hint
60 , maybe P.empty P.text hint