e2a0b46 · elk · git.iko.soy

git.iko.soy/elk

Take steps to allow higher kinded polymorphism

commite2a0b460698f4fba64ddbc96c59970c2dc8b38c8 authorEvan Czaplicki <info@elm-lang.org> dateWed 28 May 2014, 19:08 (12 years ago) parentc33ca8a

9 files changed+188−157

compare with master

unifiedsplit

compiler/AST/Module.hs+4−1 compiler/AST/Type.hs+34−20 compiler/Generate/JavaScript/Ports.hs+55−51 compiler/Parse/Type.hs+7−4 compiler/Transform/Canonicalize/Type.hs+51−51 compiler/Transform/Check.hs+4−2 compiler/Transform/Declaration.hs+6−5 compiler/Type/ExtraChecks.hs+22−21 tests/compiler/Tests/Property/Arbitrary.hs+5−2

compiler/AST/Module.hs+4−1

@@ -44,8 +44,11 @@ type CanonicalModule = Module [Var.Value] CanonicalBody

4444type Interfaces = Map.Map String Interface

4545

4646type Types = Map.Map String Type.CanonicalType

47−type ADTs = Map.Map String ( [String], [(String, [Type.CanonicalType])] )

4847type Aliases = Map.Map String ( [String], Type.CanonicalType )

48+type ADTs = Map.Map String (AdtInfo String)

49+

50+type AdtInfo v = ( [String], [(v, [Type.CanonicalType])] )

51+type CanonicalAdt = (Var.Canonical, AdtInfo Var.Canonical)

4952

5053data Interface = Interface

5154 { iVersion :: Version.Version

compiler/AST/Type.hs+34−20

@@ -13,7 +13,8 @@ import Text.PrettyPrint as P

1313data Type var

1414 = Lambda (Type var) (Type var)

1515 | Var String

16− | Data var [Type var]

16+ | Type var

17+ | App (Type var) [Type var]

1718 | Record [(String, Type var)] (Maybe (Type var))

1819 | Aliased Var.Canonical (Type var)

1920 deriving (Eq,Show)

@@ -29,10 +30,12 @@ recordOf :: [(String, Type var)] -> Type var

2930recordOf fields = Record fields Nothing

3031

3132listOf :: RawType -> RawType

32−listOf t = Data (Var.Raw "_List") [t]

33+listOf t = App (Type (Var.Raw "_List")) [t]

3334

3435tupleOf :: [RawType] -> RawType

35−tupleOf ts = Data (Var.Raw $ "_Tuple" ++ show (length ts)) ts

36+tupleOf ts = App (Type t) ts

37+ where

38+ t = Var.Raw ("_Tuple" ++ show (length ts))

3639

3740instance (Var.ToString var, Pretty var) => Pretty (Type var) where

3841 pretty tipe =

@@ -46,14 +49,18 @@ instance (Var.ToString var, Pretty var) => Pretty (Type var) where

4649

4750 Var x -> P.text x

4851

49− Data name [t] | Var.toString name == "_List" ->

50− P.brackets (pretty t)

52+ Type v -> P.text (Var.toString v)

53+

54+ App f args ->

55+ case (f,args) of

56+ (Type name, [t])

57+ | Var.toString name == "_List" -> P.brackets (pretty t)

58+

59+ (Type name, _)

60+ | Help.isTuple (Var.toString name) ->

61+ P.parens . P.sep . P.punctuate P.comma $ map pretty args

5162

52− Data name tipes

53− | Help.isTuple (Var.toString name) ->

54− P.parens . P.sep . P.punctuate P.comma $ map pretty tipes

55− | otherwise ->

56− P.hang (P.text (Var.toString name)) 2 (P.sep $ map prettyParens tipes)

63+ _ -> P.hang (pretty f) 2 (P.sep $ map prettyParens args)

5764

5865 Record _ _ ->

5966 P.braces $ case flattenRecord tipe of

@@ -78,10 +85,14 @@ prettyParens tipe = parensIf (needed tipe) (pretty tipe)

7885 needed t =

7986 case t of

8087 Aliased _ t' -> needed t'

88+

8189 Lambda _ _ -> True

82− Data name [_] | Var.toString name == "_List" -> False

83− Data _ [] -> False

84− Data _ _ -> True

90+

91+ App (Type name) [_] | Var.toString name == "_List" -> False

92+ App (Type name) _ | Help.isTuple (Var.toString name) -> False

93+ App t' [] -> needed t'

94+ App _ _ -> True

95+

8596 _ -> False

8697

8798flattenRecord :: Type var -> ( [(String, Type var)], Maybe String )

@@ -106,19 +117,22 @@ instance Binary var => Binary (Type var) where

106117 putWord8 0 >> put t1 >> put t2

107118 Var x ->

108119 putWord8 1 >> put x

109− Data ctor tipes ->

110− putWord8 2 >> put ctor >> put tipes

120+ Type name ->

121+ putWord8 2 >> put name

122+ App t1 t2 ->

123+ putWord8 3 >> put t1 >> put t2

111124 Record fs ext ->

112− putWord8 3 >> put fs >> put ext

125+ putWord8 4 >> put fs >> put ext

113126 Aliased var t ->

114− putWord8 4 >> put var >> put t

127+ putWord8 5 >> put var >> put t

115128

116129 get = do

117130 n <- getWord8

118131 case n of

119132 0 -> Lambda <$> get <*> get

120133 1 -> Var <$> get

121− 2 -> Data <$> get <*> get

122− 3 -> Record <$> get <*> get

123− 4 -> Aliased <$> get <*> get

134+ 2 -> Type <$> get

135+ 3 -> App <$> get <*> get

136+ 4 -> Record <$> get <*> get

137+ 5 -> Aliased <$> get <*> get

124138 _ -> error "Error reading a valid type from serialized string"

compiler/Generate/JavaScript/Ports.hs+55−51

@@ -2,7 +2,6 @@

22module Generate.JavaScript.Ports (incoming, outgoing) where

44import Generate.JavaScript.Helpers

5−import qualified AST.Helpers as Help

65import AST.Type as T

76import qualified AST.Variable as Var

87import Language.ECMAScript3.Syntax

@@ -29,8 +28,8 @@ incoming tipe =

2928 case tipe of

3029 Aliased _ t -> incoming t

3130

32− Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->

33− obj "Native.Ports.incomingSignal" <| incoming t

31+ App (Type v) [t]

32+ | Var.isSignal v -> obj "Native.Ports.incomingSignal" <| incoming t

3433

3534 _ -> ["v"] ==> inc tipe (ref "v")

3635

@@ -42,42 +41,44 @@ inc tipe x =

4241 Aliased _ t ->

4342 inc t x

4443

45− Data (Var.Canonical (Var.Module "Json") "Value") [] ->

46− obj "Native.Json.fromJS" <| x

47−

48− Data (Var.Canonical Var.BuiltIn ctor) []

49− | ctor == "Int" -> from JSNumber

50− | ctor == "Float" -> from JSNumber

51− | ctor == "Bool" -> from JSBoolean

52− | ctor == "String" -> from JSString

44+ Type (Var.Canonical Var.BuiltIn name)

45+ | name == "Int" -> from JSNumber

46+ | name == "Float" -> from JSNumber

47+ | name == "Bool" -> from JSBoolean

48+ | name == "String" -> from JSString

5349 where

5450 from checks = check x checks x

5551

56− Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->

57− CondExpr () (equal x (NullLit ()))

58− (obj "Maybe.Nothing")

59− (obj "Maybe.Just" <| inc t x)

52+ Type name

53+ | Var.isJson name -> obj "Native.Json.fromJS" <| x

54+ | otherwise -> error "bad type got to incoming port generation code"

6055

61− Data (Var.Canonical Var.BuiltIn ctor) [t]

62− | ctor == "_List" ->

63− check x JSArray (obj "_L.fromArray" <| array)

56+ App f args ->

57+ case f : args of

58+ Type name : [t]

59+ | Var.isMaybe name -> CondExpr () (equal x (NullLit ()))

60+ (obj "Maybe.Nothing")

61+ (obj "Maybe.Just" <| inc t x)

6462

65− | ctor == "Array.Array" ->

66− check x JSArray (obj "_A.fromJSArray" <| array)

63+ | Var.isList name -> check x JSArray (obj "_L.fromArray" <| array)

6764

68− where

69− array = DotRef () x (var "map") <| incoming t

65+ | Var.isArray name -> check x JSArray (obj "_A.fromJSArray" <| array)

66+ where

67+ array = DotRef () x (var "map") <| incoming t

7068

71− Data (Var.Canonical Var.BuiltIn ctor) ts

72− | Help.isTuple ctor -> check x JSArray tuple

73− where

74− tuple = ObjectLit () $ (prop "ctor", string ctor) : values

75− values = zipWith convert [0..] ts

76− convert n t = ( prop ('_':show n)

77− , inc t (BracketRef () x (IntLit () n)))

69+ Type name : ts

70+ | Var.isTuple name -> check x JSArray tuple

71+ where

72+ tuple = ObjectLit () $ (prop "ctor", ctor) : values

73+

74+ ctor = string ("_Tuple" ++ show (length ts))

75+ values = zipWith convert [0..] ts

76+

77+ convert n t = ( prop ('_':show n)

78+ , inc t (BracketRef () x (IntLit () n))

79+ )

7880

79− Data _ _ ->

80− error "bad ADT got to incoming port generation code"

81+ _ -> error "bad ADT got to incoming port generation code"

8182

8283 Record _ (Just _) ->

8384 error "bad record got to incoming port generation code"

@@ -94,8 +95,8 @@ outgoing tipe =

9495 case tipe of

9596 Aliased _ t -> outgoing t

9697

97− Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->

98− obj "Native.Ports.outgoingSignal" <| outgoing t

98+ App (Type v) [t]

99+ | Var.isSignal v -> obj "Native.Ports.outgoingSignal" <| outgoing t

99100

100101 _ -> ["v"] ==> out tipe (ref "v")

101102

@@ -120,30 +121,33 @@ out tipe x =

120121

121122 Var _ -> error "type variables should not be allowed through input ports"

122123

123− Data (Var.Canonical Var.BuiltIn ctor) []

124− | ctor `elem` ["Int","Float","Bool","String"] -> x

124+ Type (Var.Canonical Var.BuiltIn name)

125+ | name `elem` ["Int","Float","Bool","String"] -> x

125126

126− Data (Var.Canonical (Var.Module "Json") "Value") [] ->

127− obj "Native.Json.toJS" <| x

127+ Type name

128+ | Var.isJson name -> obj "Native.Json.toJS" <| x

129+ | otherwise -> error "bad type got to outgoing port generation code"

128130

129− Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->

130− CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

131− (NullLit ())

132− (out t (DotRef () x (var "_0")))

131+ App f args ->

132+ case f : args of

133+ Type name : [t]

134+ | Var.isMaybe name ->

135+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

136+ (NullLit ())

137+ (out t (DotRef () x (var "_0")))

133138

134− Data (Var.Canonical (Var.Module "Array") "Array") [t] ->

135− DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t

139+ | Var.isArray name ->

140+ DotRef () (obj "_A.toJSArray" <| x) (var "map") <| outgoing t

136141

137− Data (Var.Canonical Var.BuiltIn "_List") [t] ->

138− DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t

142+ | Var.isList name ->

143+ DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t

139144

140− Data (Var.Canonical Var.BuiltIn ctor) ts

141− | Help.isTuple ctor ->

142− let convert n t = out t $ DotRef () x $ var ('_':show n)

143− in ArrayLit () $ zipWith convert [0..] ts

145+ Type name : ts

146+ | Var.isTuple name ->

147+ let convert n t = out t $ DotRef () x $ var ('_':show n)

148+ in ArrayLit () $ zipWith convert [0..] ts

144149

145− Data _ _ ->

146− error "bad ADT got to outgoing port generation code"

150+ _ -> error "bad ADT got to outgoing port generation code"

147151

148152 Record _ (Just _) ->

149153 error "bad record got to outgoing port generation code"

compiler/Parse/Type.hs+7−4

@@ -47,20 +47,23 @@ capTypeVar = intercalate "." <$> dotSep1 capVar

4747constructor0 :: IParser T.RawType

4848constructor0 =

4949 do name <- capTypeVar

50− return (T.Data (Var.Raw name) [])

50+ return (T.Type (Var.Raw name))

5151

5252term :: IParser T.RawType

5353term = list <|> tuple <|> record <|> tvar <|> constructor0

5454

5555app :: IParser T.RawType

5656app =

57− do name <- capTypeVar <|> try tupleCtor <?> "type constructor"

57+ do f <- constructor0 <|> tvar <|> try tupleCtor <?> "type constructor"

5858 args <- spacePrefix term

59− return (T.Data (Var.Raw name) args)

59+ return $ case args of

60+ [] -> f

61+ _ -> T.App f args

6062 where

6163 tupleCtor = do

6264 n <- length <$> parens (many (char ','))

63− return $ "_Tuple" ++ show (if n == 0 then 0 else n+1)

65+ let ctor = "_Tuple" ++ show (if n == 0 then 0 else n+1)

66+ return (T.Type (Var.Raw ctor))

6467

6568expr :: IParser T.RawType

6669expr =

compiler/Transform/Canonicalize/Type.hs+51−51

@@ -1,8 +1,9 @@

11{-# OPTIONS_GHC -Wall #-}

2−module Transform.Canonicalize.Type where

2+module Transform.Canonicalize.Type (tipe) where

44import Control.Arrow (second)

55import Control.Applicative ((<$>),(<*>))

6+import Control.Monad (when)

67import qualified Data.Map as Map

78import Data.Traversable (traverse)

@@ -16,56 +17,55 @@ tipe :: Environment -> T.RawType -> Either String T.CanonicalType

1617tipe env typ =

1718 let go = tipe env in

1819 case typ of

19− T.Lambda a b ->

20− T.Lambda <$> go a <*> go b

20+ T.Var x -> return (T.Var x)

21+ T.Type _ -> canonicalizeApp env typ []

22+ T.App t ts -> canonicalizeApp env t ts

2123

22− T.Var x ->

23− return (T.Var x)

24+ T.Lambda a b -> T.Lambda <$> go a <*> go b

25+ T.Aliased name t -> T.Aliased name <$> go t

2426

2527 T.Record fields ext ->

26− T.Record <$> mapM go' fields <*> traverse go ext

27− where

28− go' (f,t) = (,) f <$> go t

29−

30− T.Aliased name t ->

31− T.Aliased name <$> go t

32−

33− T.Data (Var.Raw name) ts ->

34− case tvar env name of

35− Left err -> Left err

36−

37− Right (Left name') ->

38− T.Data name' <$> mapM go ts

39−

40− Right (Right (name', tvars, t))

41− | tsLen /= tvarsLen -> Left msg

42− | otherwise ->

43− do ts' <- mapM go ts

44− let t' = replace (Map.fromList (zip tvars ts')) t

45− return $ T.Aliased name' t'

46− where

47− tsLen = length ts

48− tvarsLen = length tvars

49−

50− msg = "Type alias '" ++ name ++ "' expects " ++ show tvarsLen ++

51− " type argument" ++ (if tvarsLen == 1 then "" else "s") ++

52− " but was given " ++ show tsLen

53−

54−replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType

55−replace typeTable t =

56− let go = replace typeTable in

57− case t of

58− T.Lambda a b ->

59− T.Lambda (go a) (go b)

60−

61− T.Var x ->

62− Map.findWithDefault t x typeTable

63−

64− T.Record fields ext ->

65− T.Record (map (second go) fields) (fmap go ext)

66−

67− T.Aliased original t' ->

68− T.Aliased original (go t')

69−

70− T.Data name ts ->

71− T.Data name (map go ts)

28+ let go' (f,t) = (,) f <$> go t

29+ in T.Record <$> mapM go' fields <*> traverse go ext

30+

31+canonicalizeApp :: Environment -> T.RawType -> [T.RawType]

32+ -> Either String T.CanonicalType

33+canonicalizeApp env f args =

34+ case f of

35+ T.Type (Var.Raw rawName) ->

36+ do answer <- tvar env rawName

37+ case answer of

38+ Right alias -> canonicalizeAlias env alias args

39+ Left name -> case args of

40+ [] -> return (T.Type name)

41+ _:_ -> T.App (T.Type name) <$> mapM (tipe env) args

42+

43+ _ -> T.App <$> tipe env f <*> mapM (tipe env) args

44+

45+canonicalizeAlias :: Environment -> (Var.Canonical, [String], T.CanonicalType)

46+ -> [T.RawType]

47+ -> Either String T.CanonicalType

48+canonicalizeAlias env (name, tvars, dealiasedTipe) tipes =

49+ do when (tipesLen /= tvarsLen) (Left msg)

50+ tipes' <- mapM (tipe env) tipes

51+ let tipe' = replace (Map.fromList (zip tvars tipes')) dealiasedTipe

52+ return $ T.Aliased name tipe'

53+ where

54+ tipesLen = length tipes

55+ tvarsLen = length tvars

56+

57+ msg :: String

58+ msg = "Type alias '" ++ Var.toString name ++ "' expects " ++ show tvarsLen ++

59+ " type argument" ++ (if tvarsLen == 1 then "" else "s") ++

60+ " but was given " ++ show tipesLen

61+

62+ replace :: Map.Map String T.CanonicalType -> T.CanonicalType -> T.CanonicalType

63+ replace typeTable t =

64+ let go = replace typeTable in

65+ case t of

66+ T.Lambda a b -> T.Lambda (go a) (go b)

67+ T.Var x -> Map.findWithDefault t x typeTable

68+ T.Record fields ext -> T.Record (map (second go) fields) (fmap go ext)

69+ T.Aliased original t' -> T.Aliased original (go t')

70+ T.Type _ -> t

71+ T.App f args -> T.App (go f) (map go args)

compiler/Transform/Check.hs+4−2

@@ -79,7 +79,8 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

7979 case tipe of

8080 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

8181 T.Var x -> Set.singleton x

82− T.Data _ ts -> Set.unions (map freeVars ts)

82+ T.Type _ -> Set.empty

83+ T.App t ts -> Set.unions (map freeVars (t:ts))

8384 T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)

8485 where ext' = maybe Set.empty freeVars ext

8586 T.Aliased _ t -> freeVars t

@@ -126,7 +127,8 @@ infiniteTypeAliases decls =

126127 case tipe of

127128 T.Lambda a b -> infinite a || infinite b

128129 T.Var _ -> False

129− T.Data (Var.Raw name') ts -> name == name' || any infinite ts

130+ T.Type (Var.Raw name') -> name == name'

131+ T.App t ts -> any infinite (t:ts)

130132 T.Record fields _ -> any (infinite . snd) fields

131133 T.Aliased _ t -> infinite t

132134

compiler/Transform/Declaration.hs+6−5

@@ -70,11 +70,12 @@ combineAnnotations = go

7070 _ -> (:) (D.Port (D.In name tipe)) <$> go portRest

7171

7272

73−toExpr :: [D.CanonicalDecl] -> [Canonical.Def]

74−toExpr = concatMap toDefs

73+toExpr :: String -> [D.CanonicalDecl] -> [Canonical.Def]

74+toExpr moduleName = concatMap (toDefs moduleName)

7575

76−toDefs :: D.CanonicalDecl -> [Canonical.Def]

77−toDefs decl =

76+toDefs :: String -> D.CanonicalDecl -> [Canonical.Def]

77+toDefs moduleName decl =

78+ let typeVar = Var.Canonical (Var.Module moduleName) in

7879 case decl of

7980 D.Definition def -> [def]

8081

@@ -82,7 +83,7 @@ toDefs decl =

8283 where

8384 toDefs' (ctor, tipes) =

8485 let vars = take (length tipes) arguments

85− tbody = T.Data (Var.local name) $ map T.Var tvars

86+ tbody = T.App (T.Type (typeVar name)) (map T.Var tvars)

8687 body = A.none . E.Data ctor $ map (A.none . E.localVar) vars

8788 in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]

8889

compiler/Type/ExtraChecks.hs+22−21

@@ -1,4 +1,4 @@

1−{-# OPTIONS_GHC -W #-}

1+{-# OPTIONS_GHC -Wall #-}

33{-| This module contains checks to be run *after* type inference has completed

44successfully. At that point we still need to do occurs checks and ensure that

@@ -14,9 +14,7 @@ import qualified Data.UnionFind.IO as UF

1414import Text.PrettyPrint as P

1515

1616import qualified AST.Annotation as A

17−import qualified AST.Expression.General as E

1817import qualified AST.Expression.Canonical as Canonical

19−import qualified AST.Helpers as Help

2018import qualified AST.PrettyPrint as PP

2119import qualified AST.Type as ST

2220import qualified AST.Variable as V

@@ -25,26 +23,28 @@ import qualified Type.Type as TT

2523import qualified Type.State as TS

2624import qualified Type.Alias as Alias

2725

26+throw :: [Doc] -> Either [Doc] a

2827throw err = Left [ P.vcat err ]

2928

3029mainType :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String ST.CanonicalType))

31−mainType rules env = mainCheck rules <$> Traverse.traverse TT.toSrcType env

30+mainType aliasRules environment =

31+ mainCheck aliasRules <$> Traverse.traverse TT.toSrcType environment

3232 where

3333 mainCheck :: Alias.Rules -> Map.Map String ST.CanonicalType -> Either [P.Doc] (Map.Map String ST.CanonicalType)

3434 mainCheck rules env =

3535 case Map.lookup "main" env of

3636 Nothing -> Right env

37− Just mainType

37+ Just typeOfMain

3838 | tipe `elem` acceptable -> Right env

3939 | otherwise -> throw err

4040 where

4141 acceptable = [ "Graphics.Element.Element"

4242 , "Signal.Signal Graphics.Element.Element" ]

4343

44− tipe = PP.renderPretty $ Alias.canonicalRealias (fst rules) mainType

44+ tipe = PP.renderPretty $ Alias.canonicalRealias (fst rules) typeOfMain

4545 err = [ P.text "Type Error: 'main' must have type Element or (Signal Element)."

4646 , P.text "Instead 'main' has type:\n"

47− , P.nest 4 . PP.pretty $ Alias.realias rules mainType

47+ , P.nest 4 . PP.pretty $ Alias.realias rules typeOfMain

4848 , P.text " " ]

4949

5050data Direction = In | Out

@@ -56,24 +56,25 @@ portTypes rules expr =

5656 check = isValid True False False

5757 isValid isTopLevel seenFunc seenSignal direction name tipe =

5858 case tipe of

59− ST.Data (V.Canonical (V.Module "Signal") "Signal") [t] ->

60− handleSignal t

59+ ST.Aliased _ t -> valid t

6160

62− ST.Data (V.Canonical (V.Module "Maybe") "Maybe") [t] ->

63− valid t

61+ ST.Type v

62+ | V.isJson v -> return ()

63+ | V.isPrimitive v -> return ()

64+ | otherwise -> err' True "an unsupported type"

6465

65− ST.Data (V.Canonical (V.Module "Array") "Array") [t] ->

66− valid t

66+ ST.App t [] -> valid t

6767

68− ST.Data (V.Canonical (V.Module "Json") "Value") [] ->

69− return ()

68+ ST.App (ST.Type v) [t]

69+ | V.isSignal v -> handleSignal t

70+ | V.isMaybe v -> valid t

71+ | V.isArray v -> valid t

72+ | V.isList v -> valid t

7073

71− ST.Data (V.Canonical V.BuiltIn ctor) ts

72− | ctor `elem` primitives || Help.isTuple ctor -> mapM_ valid ts

73− where

74− primitives = ["Int","Float","String","Bool","_List"]

74+ ST.App (ST.Type v) ts

75+ | V.isTuple v -> mapM_ valid ts

7576

76− ST.Data _ _ -> err' True "an unsupported type"

77+ ST.App _ _ -> err' True "an unsupported type"

7778

7879 ST.Var _ -> err "free type variables"

7980

@@ -130,7 +131,7 @@ occurs (name, variable) =

130131 desc <- liftIO $ UF.descriptor var

131132 case TT.structure desc of

132133 Nothing ->

133− modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

134+ modify $ \s -> s { TS.sErrors = fallback : TS.sErrors s }

134135 Just _ ->

135136 do liftIO $ UF.setDescriptor var (desc { TT.structure = Nothing })

136137 var' <- liftIO $ UF.fresh desc

tests/compiler/Tests/Property/Arbitrary.hs+5−2

@@ -89,7 +89,8 @@ instance Arbitrary v => Arbitrary (T.Type v) where

8989 oneof

9090 [ T.Lambda <$> depthTipe <*> depthTipe

9191 , T.Var <$> lowVar

92− , T.Data <$> arbitrary <*> genVector n tipe

92+ , T.Type <$> arbitrary

93+ , T.App <$> arbitrary <*> genVector n tipe

9394 , T.Record <$> fields <*> pure Nothing

9495 , T.Record <$> fields1 <*> (Just . T.Var <$> lowVar)

9596 ]

@@ -98,7 +99,9 @@ instance Arbitrary v => Arbitrary (T.Type v) where

9899 case tipe of

99100 T.Lambda s t -> s : t : (T.Lambda <$> shrink s <*> shrink t)

100101 T.Var _ -> []

101− T.Data n ts -> ts ++ (T.Data <$> shrink n <*> shrink ts)

102+ T.Aliased _ t -> [t]

103+ T.Type _ -> []

104+ T.App t ts -> t : ts ++ (T.App <$> shrink t <*> shrink ts)

102105 T.Record fs t -> map snd fs ++ record

103106 where

104107 record =