@@ -1,14 +1,16 @@
11module Type.Solve (solve) where
22
3−import Control.Applicative ((<$>), (<*>))
3+import Control.Applicative ((<$>), (<*>), (<|>))
44import Control.Monad
55import Control.Monad.State (StateT, execStateT, liftIO)
66import Control.Monad.Except (ExceptT, throwError)
7+import qualified Data.Foldable as F
78import qualified Data.List as List
89import qualified Data.Map as Map
9−import qualified Data.Traversable as Traversable
10+import qualified Data.Traversable as T
1011import qualified Data.UnionFind.IO as UF
1112
13+import qualified AST.Type as Type
1214import qualified Reporting.Annotation as A
1315import qualified Reporting.Error.Type as Error
1416import qualified Type.State as TS
@@ -45,7 +47,7 @@ generalize youngPool =
4547 if isRedundant then return var else TS.register var
4648
4749 let rankDict' = Map.delete youngRank rankDict
48− Traversable.traverse (mapM registerIfNotRedundant) rankDict'
50+ T.traverse (mapM registerIfNotRedundant) rankDict'
4951
5052 -- For variables with rank youngRank
5153 -- If rank < youngRank: register in oldPool
@@ -159,8 +161,9 @@ actuallySolve constraint =
159161 do env <- TS.getEnv
160162 freshCopy <-
161163 case Map.lookup name env of
162− Just tipe ->
164+ Just (A.A _ tipe) ->
163165 TS.makeInstance tipe
166+
164167 Nothing ->
165168 if List.isPrefixOf "Native." name
166169 then liftIO (variable Flexible)
@@ -170,12 +173,18 @@ actuallySolve constraint =
170173 unify Error.None region freshCopy t
171174
172175
173−solveScheme :: TypeScheme -> StateT TS.SolverState IO (Map.Map String Variable)
176+solveScheme
177+ :: TypeScheme
178+ -> StateT TS.SolverState IO (Map.Map String (A.Located Variable))
174179solveScheme scheme =
180+ let
181+ flatten (A.A region term) =
182+ A.A region <$> TS.flatten term
183+ in
175184 case scheme of
176185 Scheme [] [] constraint header ->
177186 do actuallySolve constraint
178− Traversable.traverse TS.flatten header
187+ T.traverse flatten header
179188
180189 Scheme rigidQuantifiers flexibleQuantifiers constraint header ->
181190 do let quantifiers = rigidQuantifiers ++ flexibleQuantifiers
@@ -185,7 +194,7 @@ solveScheme scheme =
185194 freshPool <- TS.nextRankPool
186195 TS.switchToPool freshPool
187196 mapM TS.introduce quantifiers
188− header' <- Traversable.traverse TS.flatten header
197+ header' <- T.traverse flatten header
189198 actuallySolve constraint
190199
191200 allDistinct rigidQuantifiers
@@ -234,46 +243,53 @@ crash msg =
234243 ++ "<https://github.com/elm-lang/elm-compiler/issues>"
235244
236245
237−occurs :: (String, Variable) -> StateT TS.SolverState IO ()
238−occurs (_name, variable) =
239− do vars <- liftIO $ infiniteVars [] variable
240− case vars of
241− [] ->
242− return ()
243−
244− var : _ ->
245− do desc <- liftIO $ UF.descriptor var
246− let region = error "TODO:occurs"
247− case structure desc of
248− Nothing ->
249− TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))
250−
251− Just _ ->
252− TS.addError region (Error.InfiniteType undefined (error "TODO:occurs"))
253− where
254− infiniteVars :: [Variable] -> Variable -> IO [Variable]
255− infiniteVars seen var =
256− let go = infiniteVars (var:seen)
257− in
258− if var `elem` seen
259− then return [var]
260− else do
261− desc <- UF.descriptor var
246+occurs :: (String, A.Located Variable) -> StateT TS.SolverState IO ()
247+occurs (name, A.A region variable) =
248+ do maybePair <- liftIO $ occursHelp [] variable
249+ case maybePair of
250+ Nothing ->
251+ return ()
252+
253+ Just (t1, t2) ->
254+ let
255+ info = Error.InfiniteTypeInfo name t1 t2
256+ in
257+ TS.addError region (Error.InfiniteType info)
258+
259+
260+occursHelp
261+ :: [Variable]
262+ -> Variable
263+ -> IO (Maybe (Type.Canonical, Type.Canonical))
264+occursHelp seen var =
265+ if elem var seen then
266+ do desc <- UF.descriptor var
267+ UF.setDescriptor var (desc { structure = Nothing })
268+ var' <- UF.fresh desc
269+ srcVar <- toSrcType var
270+ srcVar' <- toSrcType var'
271+ return (Just (srcVar, srcVar'))
272+ else
273+ do desc <- UF.descriptor var
262274 case structure desc of
263− Nothing -> return []
275+ Nothing ->
276+ return Nothing
277+
264278 Just struct ->
279+ let go = occursHelp (var:seen)
280+ in
265281 case struct of
266282 App1 a b ->
267− (++) <$> go a <*> go b
283+ (<|>) <$> go a <*> go b
268284
269285 Fun1 a b ->
270− (++) <$> go a <*> go b
286+ (<|>) <$> go a <*> go b
271287
272288 Var1 a ->
273289 go a
274290
275291 EmptyRecord1 ->
276− return []
292+ return Nothing
277293
278294 Record1 fields ext ->
279− concat <$> mapM go (ext : concat (Map.elems fields))
295+ F.asum <$> mapM go (ext : concat (Map.elems fields))