git.iko.soy/elk
on master help sign in
Add "alias" as a field in tvars and TermN's
b16e876Evan Czaplicki
compiler/Type/Constrain/Expression.hs+12−12
compare with master
unifiedsplit
@@ -47,7 +47,7 @@ constrain env (A region expr) tipe =
47 else record (Map.map (\t -> [glTipe t]) decls) baseRec
47 else record (Map.map (\t -> [glTipe t]) decls) baseRec
48 attribute = makeRec Lit.attribute attr
48 attribute = makeRec Lit.attribute attr
49 uniform = makeRec Lit.uniform unif
49 uniform = makeRec Lit.uniform unif
50− varying = makeRec Lit.varying (TermN EmptyRecord1)
50+ varying = makeRec Lit.varying (termN EmptyRecord1)
51 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
51 in return . A region $ CEqual tipe (shaderTipe attribute uniform varying)
52
52
53 Var var
53 Var var
@@ -107,7 +107,7 @@ constrain env (A region expr) tipe =
107
107
108 Data name exprs ->
108 Data name exprs ->
109 do vars <- forM exprs $ \_ -> liftIO (var Flexible)
109 do vars <- forM exprs $ \_ -> liftIO (var Flexible)
110− let pairs = zip exprs (map VarN vars)
110+ let pairs = zip exprs (map varN vars)
111 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)
111 (ctipe, cs) <- Monad.foldM step (tipe,true) (reverse pairs)
112 return $ ex vars (cs /\ name <? ctipe)
112 return $ ex vars (cs /\ name <? ctipe)
113 where
113 where
@@ -134,27 +134,27 @@ constrain env (A region expr) tipe =
134 Modify e fields ->
134 Modify e fields ->
135 exists $ \t -> do
135 exists $ \t -> do
136 oldVars <- forM fields $ \_ -> liftIO (var Flexible)
136 oldVars <- forM fields $ \_ -> liftIO (var Flexible)
137− let oldFields = ST.fieldMap (zip (map fst fields) (map VarN oldVars))
137+ let oldFields = ST.fieldMap (zip (map fst fields) (map varN oldVars))
138 cOld <- ex oldVars <$> constrain env e (record oldFields t)
138 cOld <- ex oldVars <$> constrain env e (record oldFields t)
139
139
140 newVars <- forM fields $ \_ -> liftIO (var Flexible)
140 newVars <- forM fields $ \_ -> liftIO (var Flexible)
141− let newFields = ST.fieldMap (zip (map fst fields) (map VarN newVars))
141+ let newFields = ST.fieldMap (zip (map fst fields) (map varN newVars))
142 let cNew = tipe === record newFields t
142 let cNew = tipe === record newFields t
143
143
144− cs <- zipWithM (constrain env) (map snd fields) (map VarN newVars)
144+ cs <- zipWithM (constrain env) (map snd fields) (map varN newVars)
145
145
146 return $ cOld /\ ex newVars (and (cNew : cs))
146 return $ cOld /\ ex newVars (and (cNew : cs))
147
147
148 Record fields ->
148 Record fields ->
149 do vars <- forM fields $ \_ -> liftIO (var Flexible)
149 do vars <- forM fields $ \_ -> liftIO (var Flexible)
150− cs <- zipWithM (constrain env) (map snd fields) (map VarN vars)
150+ cs <- zipWithM (constrain env) (map snd fields) (map varN vars)
151− let fields' = ST.fieldMap (zip (map fst fields) (map VarN vars))
151+ let fields' = ST.fieldMap (zip (map fst fields) (map varN vars))
152− recordType = record fields' (TermN EmptyRecord1)
152+ recordType = record fields' (termN EmptyRecord1)
153 return . ex vars . and $ tipe === recordType : cs
153 return . ex vars . and $ tipe === recordType : cs
154
154
155 Markdown _ _ es ->
155 Markdown _ _ es ->
156 do vars <- forM es $ \_ -> liftIO (var Flexible)
156 do vars <- forM es $ \_ -> liftIO (var Flexible)
157− let tvars = map VarN vars
157+ let tvars = map varN vars
158 cs <- zipWithM (constrain env) es tvars
158 cs <- zipWithM (constrain env) es tvars
159 return . ex vars $ and ("Text.markdown" <? tipe : cs)
159 return . ex vars $ and ("Text.markdown" <? tipe : cs)
160
160
@@ -182,7 +182,7 @@ constrainDef env info (Canonical.Definition pattern expr maybeTipe) =
182 case (pattern, maybeTipe) of
182 case (pattern, maybeTipe) of
183 (P.Var name, Just tipe) -> do
183 (P.Var name, Just tipe) -> do
184 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
184 flexiVars <- forM qs (\_ -> liftIO $ var Flexible)
185− let inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs flexiVars
185+ let inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs flexiVars
186 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
186 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
187 (vars, typ) <- Env.instantiateType env tipe Map.empty
187 (vars, typ) <- Env.instantiateType env tipe Map.empty
188 let scheme = Scheme { rigidQuantifiers = [],
188 let scheme = Scheme { rigidQuantifiers = [],
@@ -199,8 +199,8 @@ constrainDef env info (Canonical.Definition pattern expr maybeTipe) =
199
199
200 (P.Var name, Nothing) -> do
200 (P.Var name, Nothing) -> do
201 v <- liftIO $ var Flexible
201 v <- liftIO $ var Flexible
202− let tipe = VarN v
202+ let tipe = varN v
203− inserts = zipWith (\arg typ -> Map.insert arg (VarN typ)) qs rigidVars
203+ inserts = zipWith (\arg typ -> Map.insert arg (varN typ)) qs rigidVars
204 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
204 env' = env { Env.value = List.foldl' (\x f -> f x) (Env.value env) inserts }
205 c <- constrain env' expr tipe
205 c <- constrain env' expr tipe
206 return ( schemes
206 return ( schemes
compiler/Type/Constrain/Literal.hs+1−1
@@ -15,7 +15,7 @@ constrain env region literal tipe =
15
15
16 litType =
16 litType =
17 case literal of
17 case literal of
18− IntNum _ -> VarN `fmap` var (Is Number)
18+ IntNum _ -> varN `fmap` var (Is Number)
19 FloatNum _ -> prim "Float"
19 FloatNum _ -> prim "Float"
20 Chr _ -> prim "Char"
20 Chr _ -> prim "Char"
21 Str _ -> prim "String"
21 Str _ -> prim "String"
compiler/Type/Constrain/Pattern.hs+3−3
@@ -36,9 +36,9 @@ constrain env pattern tipe =
36 P.Var name -> do
36 P.Var name -> do
37 v <- liftIO $ var Flexible
37 v <- liftIO $ var Flexible
38 return $ Fragment {
38 return $ Fragment {
39− typeEnv = Map.singleton name (VarN v),
39+ typeEnv = Map.singleton name (varN v),
40 vars = [v],
40 vars = [v],
41− typeConstraint = VarN v === tipe
41+ typeConstraint = varN v === tipe
42 }
42 }
43
43
44 P.Alias name p -> do
44 P.Alias name p -> do
@@ -66,7 +66,7 @@ constrain env pattern tipe =
66
66
67 P.Record fields -> do
67 P.Record fields -> do
68 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
68 pairs <- liftIO $ mapM (\name -> (,) name <$> var Flexible) fields
69− let tenv = Map.fromList (map (second VarN) pairs)
69+ let tenv = Map.fromList (map (second varN) pairs)
70 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
70 c <- exists $ \t -> return (tipe === record (Map.map (:[]) tenv) t)
71 return $ Fragment {
71 return $ Fragment {
72 typeEnv = tenv,
72 typeEnv = tenv,
compiler/Type/Environment.hs+17−13
@@ -44,12 +44,12 @@ makeTypes datatypes =
44 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
44 makeImported :: (V.Canonical, AdtInfo V.Canonical) -> IO (String, Type)
45 makeImported (var, _) = do
45 makeImported (var, _) = do
46 tvar <- namedVar Constant var
46 tvar <- namedVar Constant var
47− return (V.toString var, VarN tvar)
47+ return (V.toString var, varN tvar)
48
48
49 makeBuiltin :: (String, Int) -> IO (String, Type)
49 makeBuiltin :: (String, Int) -> IO (String, Type)
50 makeBuiltin (name, _) = do
50 makeBuiltin (name, _) = do
51 name' <- namedVar Constant (V.builtin name)
51 name' <- namedVar Constant (V.builtin name)
52− return (name, VarN name')
52+ return (name, varN name')
53
53
54 builtins :: [(String, Int)]
54 builtins :: [(String, Int)]
55 builtins = concat [ map tuple [0..9]
55 builtins = concat [ map tuple [0..9]
@@ -72,7 +72,7 @@ makeConstructors env datatypes = Map.fromList builtins
72 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
72 inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)
73 inst numTVars tipe = do
73 inst numTVars tipe = do
74 vars <- forM [1..numTVars] $ \_ -> var Flexible
74 vars <- forM [1..numTVars] $ \_ -> var Flexible
75− let (args, result) = tipe (map VarN vars)
75+ let (args, result) = tipe (map (varN) vars)
76 return (length args, vars, args, result)
76 return (length args, vars, args, result)
77
77
78 tupleCtor n =
78 tupleCtor n =
@@ -132,24 +132,28 @@ instantiator env sourceType = go sourceType
132 T.Var x -> do
132 T.Var x -> do
133 dict <- State.get
133 dict <- State.get
134 case Map.lookup x dict of
134 case Map.lookup x dict of
135− Just v -> return (VarN v)
135+ Just v -> return (varN v)
136 Nothing ->
136 Nothing ->
137− do var <- State.liftIO $ namedVar flex (V.local x)
137+ do v <- State.liftIO $ namedVar flex (V.local x)
138− State.put (Map.insert x var dict)
138+ State.put (Map.insert x v dict)
139− return (VarN var)
139+ return (varN v)
140 where
140 where
141 flex | "number" `isPrefixOf` x = Is Number
141 flex | "number" `isPrefixOf` x = Is Number
142 | "comparable" `isPrefixOf` x = Is Comparable
142 | "comparable" `isPrefixOf` x = Is Comparable
143 | "appendable" `isPrefixOf` x = Is Appendable
143 | "appendable" `isPrefixOf` x = Is Appendable
144 | otherwise = Flexible
144 | otherwise = Flexible
145
145
146− T.Aliased _ t -> go t
146+ T.Aliased name t -> do
147+ t' <- go t
148+ case t' of
149+ VarN _ v -> return (VarN (Just name) v)
150+ TermN _ term -> return (TermN (Just name) term)
147
151
148− T.Type var ->
152+ T.Type name ->
149− case Map.lookup (V.toString var) (types env) of
153+ case Map.lookup (V.toString name) (types env) of
150 Just t -> return t
154 Just t -> return t
151 Nothing -> error $ "Could not find type constructor '" ++
155 Nothing -> error $ "Could not find type constructor '" ++
152− V.toString var ++ "' while checking types."
156+ V.toString name ++ "' while checking types."
153
157
154 T.App t ts -> do
158 T.App t ts -> do
155 t' <- go t
159 t' <- go t
@@ -159,6 +163,6 @@ instantiator env sourceType = go sourceType
159 T.Record fields ext -> do
163 T.Record fields ext -> do
160 fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
164 fields' <- Traverse.traverse (mapM go) (T.fieldMap fields)
161 ext' <- case ext of
165 ext' <- case ext of
162− Nothing -> return $ TermN EmptyRecord1
166+ Nothing -> return $ termN EmptyRecord1
163 Just x -> go x
167 Just x -> go x
164− return $ TermN (Record1 fields' ext')
168+ return $ termN (Record1 fields' ext')
compiler/Type/Inference.hs+2−2
@@ -41,7 +41,7 @@ infer interfaces modul = unsafePerformIO $ do
41 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
41 environ = noneNoDocs . T.CLet [ T.Scheme vars [] (noneNoDocs T.CTrue) header ]
42
42
43 fvar <- liftIO $ T.var T.Flexible
43 fvar <- liftIO $ T.var T.Flexible
44− c <- TcExpr.constrain env (program moduleBody) (T.VarN fvar)
44+ c <- TcExpr.constrain env (program moduleBody) (T.varN fvar)
45 return (header, environ c)
45 return (header, environ c)
46
46
47 case attemptConstraint of
47 case attemptConstraint of
@@ -62,7 +62,7 @@ canonicalizeValues :: Env.Environment -> (String, Interface)
62canonicalizeValues env (moduleName, iface) =
62canonicalizeValues env (moduleName, iface) =
63 forM (Map.toList (iTypes iface)) $ \(name,tipe) -> do
63 forM (Map.toList (iTypes iface)) $ \(name,tipe) -> do
64 tipe' <- Env.instantiateType env tipe Map.empty
64 tipe' <- Env.instantiateType env tipe Map.empty
65− return (moduleName ++ "." ++ name, tipe')
65+ return (moduleName ++ "." ++ name, tipe')
66
66
67canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
67canonicalizeAdts :: Interfaces -> CanonicalModule -> [CanonicalAdt]
68canonicalizeAdts interfaces modul =
68canonicalizeAdts interfaces modul =
compiler/Type/State.hs+25−21
@@ -104,17 +104,20 @@ introduce variable = do
104flatten :: Type -> StateT SolverState IO Variable
104flatten :: Type -> StateT SolverState IO Variable
105flatten term =
105flatten term =
106 case term of
106 case term of
107+ VarN alias v -> do
108+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { alias = alias }
107− VarN v -> return v
109+ return v
108− TermN t -> do
110+ TermN alias t -> do
109 flatStructure <- traverseTerm flatten t
111 flatStructure <- traverseTerm flatten t
110 pool <- getPool
112 pool <- getPool
111− var <- liftIO . UF.fresh $ Descriptor {
113+ var <- liftIO . UF.fresh $ Descriptor
112− structure = Just flatStructure,
114+ { structure = Just flatStructure
113− rank = maxRank pool,
115+ , rank = maxRank pool
114− flex = Flexible,
116+ , flex = Flexible
115− name = Nothing,
117+ , name = Nothing
116− copy = Nothing,
118+ , copy = Nothing
117− mark = noMark
119+ , mark = noMark
120+ , alias = alias
118 }
121 }
119 register var
122 register var
120
123
@@ -140,18 +143,19 @@ makeCopy alreadyCopied variable = do
140
143
141 | otherwise -> do
144 | otherwise -> do
142 pool <- getPool
145 pool <- getPool
143− newVar <- liftIO $ UF.fresh $ Descriptor {
146+ newVar <- liftIO $ UF.fresh $ Descriptor
144− structure = Nothing,
147+ { structure = Nothing
145− rank = maxRank pool,
148+ , rank = maxRank pool
146− mark = noMark,
149+ , mark = noMark
147− flex = case flex desc of
150+ , flex = case flex desc of
148− Is s -> Is s
151+ Is s -> Is s
149− _ -> Flexible,
152+ _ -> Flexible
150− copy = Nothing,
153+ , copy = Nothing
151− name = case flex desc of
154+ , name = case flex desc of
152− Rigid -> Nothing
155+ Rigid -> Nothing
153− _ -> name desc
156+ _ -> name desc
157+ , alias = Nothing
154− }
158+ }
155 register newVar
159 register newVar
156
160
157 -- Link the original variable to the new variable. This lets us
161 -- Link the original variable to the new variable. This lets us
compiler/Type/Type.hs+31−17
@@ -13,6 +13,7 @@ import Control.Monad.State
13import Control.Monad.Error
13import Control.Monad.Error
14import Data.Traversable (traverse)
14import Data.Traversable (traverse)
15import AST.Annotation
15import AST.Annotation
16+import qualified AST.PrettyPrint as PP
16import qualified AST.Type as T
17import qualified AST.Type as T
17import qualified AST.Variable as Var
18import qualified AST.Variable as Var
18
19
@@ -25,12 +26,18 @@ data Term1 a
25 deriving Show
26 deriving Show
26
27
27data TermN a
28data TermN a
28− = VarN a
29+ = VarN (Maybe Var.Canonical) a
29− | TermN (Term1 (TermN a))
30+ | TermN (Maybe Var.Canonical) (Term1 (TermN a))
30 deriving Show
31 deriving Show
31
32
33+varN :: a -> TermN a
34+varN = VarN Nothing
35+
36+termN :: (Term1 (TermN a)) -> TermN a
37+termN = TermN Nothing
38+
32record :: Map.Map String [TermN a] -> TermN a -> TermN a
39record :: Map.Map String [TermN a] -> TermN a -> TermN a
33−record fs rec = TermN (Record1 fs rec)
40+record fs rec = termN (Record1 fs rec)
34
41
35type Type = TermN Variable
42type Type = TermN Variable
36type Variable = UF.Point Descriptor
43type Variable = UF.Point Descriptor
@@ -71,9 +78,9 @@ a@(A _ c1) /\ b@(A _ c2) =
71
78
72infixr 9 ==>
79infixr 9 ==>
73(==>) :: Type -> Type -> Type
80(==>) :: Type -> Type -> Type
74−a ==> b = TermN (Fun1 a b)
81+a ==> b = termN (Fun1 a b)
75
82
76−f <| a = TermN (App1 f a)
83+f <| a = termN (App1 f a)
77
84
78data Descriptor = Descriptor
85data Descriptor = Descriptor
79 { structure :: Maybe (Term1 Variable)
86 { structure :: Maybe (Term1 Variable)
@@ -82,6 +89,7 @@ data Descriptor = Descriptor
82 , name :: Maybe TypeName
89 , name :: Maybe TypeName
83 , copy :: Maybe Variable
90 , copy :: Maybe Variable
84 , mark :: Int
91 , mark :: Int
92+ , alias :: Maybe Var.Canonical
85 } deriving Show
93 } deriving Show
86
94
87noRank = -1
95noRank = -1
@@ -104,6 +112,7 @@ namedVar flex name = UF.fresh $ Descriptor
104 , name = Just name
112 , name = Just name
105 , copy = Nothing
113 , copy = Nothing
106 , mark = noMark
114 , mark = noMark
115+ , alias = Nothing
107 }
116 }
108
117
109var :: Flex -> IO Variable
118var :: Flex -> IO Variable
@@ -114,6 +123,7 @@ var flex = UF.fresh $ Descriptor
114 , name = Nothing
123 , name = Nothing
115 , copy = Nothing
124 , copy = Nothing
116 , mark = noMark
125 , mark = noMark
126+ , alias = Nothing
117 }
127 }
118
128
119
129
@@ -130,12 +140,12 @@ fl rqs constraint@(A ann _) =
130exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
140exists :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
131exists f = do
141exists f = do
132 v <- liftIO $ var Flexible
142 v <- liftIO $ var Flexible
133− ex [v] <$> f (VarN v)
143+ ex [v] <$> f (varN v)
134
144
135existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
145existsNumber :: Error e => (Type -> ErrorT e IO TypeConstraint) -> ErrorT e IO TypeConstraint
136existsNumber f = do
146existsNumber f = do
137 v <- liftIO $ var (Is Number)
147 v <- liftIO $ var (Is Number)
138− ex [v] <$> f (VarN v)
148+ ex [v] <$> f (varN v)
139
149
140
150
141instance Show a => Show (UF.Point a) where
151instance Show a => Show (UF.Point a) where
@@ -185,9 +195,13 @@ instance PrettyType a => PrettyType (Term1 a) where
185instance PrettyType a => PrettyType (TermN a) where
195instance PrettyType a => PrettyType (TermN a) where
186 pretty when term =
196 pretty when term =
187 case term of
197 case term of
188− VarN x -> pretty when x
198+ VarN alias x -> either alias (pretty when x)
189− TermN t1 -> pretty when t1
199+ TermN alias t1 -> either alias (pretty when t1)
190−
200+ where
201+ either maybeAlias doc =
202+ case maybeAlias of
203+ Just alias -> PP.pretty alias
204+ Nothing -> doc
191
205
192instance PrettyType Descriptor where
206instance PrettyType Descriptor where
193 pretty when desc =
207 pretty when desc =
@@ -321,8 +335,8 @@ instance (Crawl t, Crawl v) => Crawl (Scheme t v) where
321instance Crawl t => Crawl (TermN t) where
335instance Crawl t => Crawl (TermN t) where
322 crawl nextState tipe =
336 crawl nextState tipe =
323 case tipe of
337 case tipe of
324− VarN x -> VarN <$> crawl nextState x
338+ VarN a x -> VarN a <$> crawl nextState x
325− TermN term -> TermN <$> crawl nextState term
339+ TermN a term -> TermN a <$> crawl nextState term
326
340
327instance Crawl t => Crawl (Term1 t) where
341instance Crawl t => Crawl (Term1 t) where
328 crawl nextState term =
342 crawl nextState term =
@@ -355,7 +369,7 @@ toSrcType :: Variable -> IO T.CanonicalType
355toSrcType variable =
369toSrcType variable =
356 do desc <- UF.descriptor =<< addNames variable
370 do desc <- UF.descriptor =<< addNames variable
357 srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)
371 srcType <- maybe (backupSrcType desc) termToSrcType (structure desc)
358− return srcType
372+ return $ maybe srcType (\name -> T.Aliased name srcType) (alias desc)
359 where
373 where
360 backupSrcType desc =
374 backupSrcType desc =
361 case name desc of
375 case name desc of
@@ -402,11 +416,11 @@ collectApps variable = go [] variable
402 desc <- UF.descriptor variable
416 desc <- UF.descriptor variable
403 case (structure desc, vars) of
417 case (structure desc, vars) of
404 (Nothing, [v]) -> case name desc of
418 (Nothing, [v]) -> case name desc of
405− Just n | Var.isList n -> return (List v)
419+ Just n | Var.isList n -> return (List v)
406− _ -> return Other
420+ _ -> return Other
407 (Nothing, vs) -> case name desc of
421 (Nothing, vs) -> case name desc of
408− Just n | Var.isTuple n -> return (Tuple vs)
422+ Just n | Var.isTuple n -> return (Tuple vs)
409− _ -> return Other
423+ _ -> return Other
410 (Just term, _) -> case term of
424 (Just term, _) -> case term of
411 App1 a b -> go (vars ++ [b]) a
425 App1 a b -> go (vars ++ [b]) a
412 _ -> return Other
426 _ -> return Other
compiler/Type/Unify.hs+32−15
@@ -1,6 +1,7 @@
1{-# OPTIONS_GHC -W #-}
1{-# OPTIONS_GHC -W #-}
2module Type.Unify (unify) where
2module Type.Unify (unify) where
3
3
4+import Control.Applicative ((<|>))
4import Control.Monad.State
5import Control.Monad.State
5import qualified Data.List as List
6import qualified Data.List as List
6import qualified Data.Map as Map
7import qualified Data.Map as Map
@@ -51,32 +52,48 @@ actuallyUnify region variable1 variable2 = do
51 rank' :: Int
52 rank' :: Int
52 rank' = min (rank desc1) (rank desc2)
53 rank' = min (rank desc1) (rank desc2)
53
54
55+ alias' :: Maybe Var.Canonical
56+ alias' = alias desc1 <|> alias desc2
57+
54 merge1 :: StateT TS.SolverState IO ()
58 merge1 :: StateT TS.SolverState IO ()
55 merge1 = liftIO $ do
59 merge1 = liftIO $ do
56 if rank desc1 < rank desc2 then UF.union variable2 variable1
60 if rank desc1 < rank desc2 then UF.union variable2 variable1
57 else UF.union variable1 variable2
61 else UF.union variable1 variable2
58 UF.modifyDescriptor variable1 $ \desc ->
62 UF.modifyDescriptor variable1 $ \desc ->
59− desc { structure = structure desc1, flex = flex', name = name' }
63+ desc { structure = structure desc1
64+ , flex = flex'
65+ , name = name'
66+ , alias = alias'
67+ }
60
68
61 merge2 :: StateT TS.SolverState IO ()
69 merge2 :: StateT TS.SolverState IO ()
62 merge2 = liftIO $ do
70 merge2 = liftIO $ do
63 if rank desc1 < rank desc2 then UF.union variable2 variable1
71 if rank desc1 < rank desc2 then UF.union variable2 variable1
64 else UF.union variable1 variable2
72 else UF.union variable1 variable2
65 UF.modifyDescriptor variable2 $ \desc ->
73 UF.modifyDescriptor variable2 $ \desc ->
66− desc { structure = structure desc2, flex = flex', name = name' }
74+ desc { structure = structure desc2
75+ , flex = flex'
76+ , name = name'
77+ , alias = alias'
78+ }
67
79
68 merge = if rank desc1 < rank desc2 then merge1 else merge2
80 merge = if rank desc1 < rank desc2 then merge1 else merge2
69
81
70 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
82 fresh :: Maybe (Term1 Variable) -> StateT TS.SolverState IO Variable
71 fresh structure = do
83 fresh structure = do
72− var <- liftIO . UF.fresh $ Descriptor {
84+ v <- liftIO . UF.fresh $ Descriptor
73− structure = structure, rank = rank', flex = flex',
85+ { structure = structure
86+ , rank = rank'
87+ , flex = flex'
88+ , name = name'
74− name = name', copy = Nothing, mark = noMark
89+ , copy = Nothing
90+ , mark = noMark
91+ , alias = alias'
75− }
92+ }
76− TS.register var
93+ TS.register v
77−
94+
78− flexAndUnify var = do
95+ flexAndUnify v = do
79− liftIO $ UF.modifyDescriptor var $ \desc -> desc { flex = Flexible }
96+ liftIO $ UF.modifyDescriptor v $ \desc -> desc { flex = Flexible }
80 unify' variable1 variable2
97 unify' variable1 variable2
81
98
82 unifyNumber svar (Var.Canonical home name) =
99 unifyNumber svar (Var.Canonical home name) =
@@ -94,10 +111,10 @@ actuallyUnify region variable1 variable2 = do
94 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
111 TS.addError region (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
95 where msg = "An appendable must be of type String, List, or Text."
112 where msg = "An appendable must be of type String, List, or Text."
96
113
97− unifyComparable var (Var.Canonical home name) =
114+ unifyComparable v (Var.Canonical home name) =
98 case home of
115 case home of
99− Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify var
116+ Var.BuiltIn | name `elem` ["Int","Float","Char","String"] -> flexAndUnify v
100− Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify var
117+ Var.Local | List.isPrefixOf "comparable" name -> flexAndUnify v
101 _ -> comparableError Nothing
118 _ -> comparableError Nothing
102
119
103 unifyComparableStructure varSuper varFlex =
120 unifyComparableStructure varSuper varFlex =
@@ -122,8 +139,8 @@ actuallyUnify region variable1 variable2 = do
122
139
123 rigidError variable = TS.addError region (Just hint) variable1 variable2
140 rigidError variable = TS.addError region (Just hint) variable1 variable2
124 where
141 where
125− var = "'" ++ render (pretty Never variable) ++ "'"
142+ v = "'" ++ render (pretty Never variable) ++ "'"
126− hint = "Cannot unify rigid type variable " ++ var ++
143+ hint = "Cannot unify rigid type variable " ++ v ++
127 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\
144 ".\nThe problem probably relates to a type annotation. Note that rigid type\n\
128 \variables are not shared between a top-level and let-bound type annotations."
145 \variables are not shared between a top-level and let-bound type annotations."
129
146