b09bb00 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Upgrade Type code from String to Text

b09bb00Evan Czaplicki10 years ago

src/AST/Literal.hs+9−11

compare with master

unifiedsplit

@@ -8,8 +8,6 @@ import Data.Text.Lazy.Builder (Builder, fromString)

8import Data.Text.Lazy.Builder.Int (decimal)

9import Data.Text.Lazy.Builder.RealFloat (realFloat)

11−import qualified AST.Variable as Var

12−

15-- LITERALS

13-- LITERALS

@@ -49,16 +47,16 @@ data GLType

49 deriving (Eq)

47 deriving (Eq)

52−glTypeToVar :: GLType -> Var.Canonical

50+glTypeToText :: GLType -> Text

53−glTypeToVar glTipe =

51+glTypeToText glTipe =

54 case glTipe of

52 case glTipe of

55− V2 -> Var.inLinearAlgebra "Math.Vector2" "Vec2"

53+ V2 -> "Math.Vector2.Vec2"

56− V3 -> Var.inLinearAlgebra "Math.Vector3" "Vec3"

54+ V3 -> "Math.Vector3.Vec3"

57− V4 -> Var.inLinearAlgebra "Math.Vector4" "Vec4"

55+ V4 -> "Math.Vector4.Vec4"

58− M4 -> Var.inLinearAlgebra "Math.Matrix4" "Mat4"

56+ M4 -> "Math.Matrix4.Mat4"

59− Int -> Var.builtin "Int"

57+ Int -> "Int"

60− Float -> Var.builtin "Float"

58+ Float -> "Float"

61− Texture -> Var.inWebGL "WebGL" "Texture"

59+ Texture -> "WebGL.Texture"

64data Shader =

62data Shader =

src/AST/Module/Name.hs−10

@@ -34,16 +34,6 @@ inHtml raw =

34 Canonical Package.html raw

37−inWebGL :: Raw -> Canonical

38−inWebGL raw =

39− Canonical Package.webgl raw

40−

41−

42−inLinearAlgebra :: Raw -> Canonical

43−inLinearAlgebra raw =

44− Canonical Package.linearAlgebra raw

45−

46−

47toString :: Raw -> String

37toString :: Raw -> String

48toString =

38toString =

49 Text.unpack

39 Text.unpack

src/AST/Variable.hs−10

@@ -80,16 +80,6 @@ inHtml home name =

80 Canonical (Module (ModuleName.inHtml home)) name

83−inWebGL :: ModuleName.Raw -> Text -> Canonical

84−inWebGL home name =

85− Canonical (Module (ModuleName.inWebGL home)) name

86−

87−

88−inLinearAlgebra :: ModuleName.Raw -> Text -> Canonical

89−inLinearAlgebra home name =

90− Canonical (Module (ModuleName.inLinearAlgebra home)) name

91−

92−

93cmd :: Canonical

83cmd :: Canonical

94cmd =

84cmd =

95 inCore "Platform.Cmd" "Cmd"

85 inCore "Platform.Cmd" "Cmd"

src/Elm/Package.hs−10

@@ -47,16 +47,6 @@ html =

47 Name "elm-lang" "html"

50−webgl :: Name

51−webgl =

52− Name "elm-community" "webgl"

53−

54−

55−linearAlgebra :: Name

56−linearAlgebra =

57− Name "elm-community" "linear-algebra"

58−

59−

60toString :: Name -> String

50toString :: Name -> String

61toString name =

51toString name =

62 Text.unpack (toText name)

52 Text.unpack (toText name)

src/Nitpick/TopLevelTypes.hs+4−3

@@ -6,6 +6,7 @@ import qualified Data.Foldable as F

6import Data.Map ((!))

7import qualified Data.Map as Map

8import qualified Data.Text as Text

9+import Data.Text (Text)

10import qualified AST.Expression.Canonical as Can

11import qualified AST.Expression.Canonical as Can

11import qualified AST.Module.Name as ModuleName

12import qualified AST.Module.Name as ModuleName

@@ -26,7 +27,7 @@ type Result =

28type TypeDict =

29type TypeDict =

29− Map.Map Var.Canonical Type.Canonical

30+ Map.Map Text Type.Canonical

@@ -64,7 +65,7 @@ checkAnnotation typeEnv (Can.Def _ (A.A region pattern) _ maybeType) =

64 (P.Var name, Nothing) ->

65 (P.Var name, Nothing) ->

65 let

66 let

66 warning =

67 warning =

67− Warning.MissingTypeAnnotation (Text.unpack name) (typeEnv ! Var.local name)

68+ Warning.MissingTypeAnnotation (Text.unpack name) (typeEnv ! name)

68 in

69 in

69 Result.warn region warning ()

70 Result.warn region warning ()

@@ -80,7 +81,7 @@ checkMain :: TypeDict -> Can.Def -> Result Can.Def

80checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =

81checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =

81 let

82 let

82 mainType =

83 mainType =

83− typeEnv ! Var.local "main"

84+ typeEnv ! "main"

85 makeError tipe maybeMsg =

86 makeError tipe maybeMsg =

86 A.A region (Error.BadFlags tipe maybeMsg)

87 A.A region (Error.BadFlags tipe maybeMsg)

src/Type/Constrain/Effects.hs+7−1

@@ -1,7 +1,9 @@

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module Type.Constrain.Effects (constrain) where

3module Type.Constrain.Effects (constrain) where

4import qualified Data.Map as Map

5import qualified Data.Map as Map

6+import Data.Monoid ((<>))

6import qualified AST.Effects as Effects

8import qualified AST.Effects as Effects

7import qualified AST.Module.Name as ModuleName

9import qualified AST.Module.Name as ModuleName

@@ -14,6 +16,10 @@ import Type.Type

14 )

16 )

19+

20+-- CONSTRAIN EFFECTS

21+

22+

17constrain :: Env.Env -> ModuleName.Canonical -> Effects.Canonical -> IO TypeConstraint

23constrain :: Env.Env -> ModuleName.Canonical -> Effects.Canonical -> IO TypeConstraint

18constrain env moduleName effects =

24constrain env moduleName effects =

19 case effects of

25 case effects of

@@ -88,7 +94,7 @@ addEffectArgs

88addEffectArgs env moduleName managerType msg result =

94addEffectArgs env moduleName managerType msg result =

89 let

95 let

90 toTypeName (A.A _ name) =

96 toTypeName (A.A _ name) =

91− ModuleName.canonicalToString moduleName ++ "." ++ name

97+ ModuleName.canonicalToText moduleName <> "." <> name

93 effectList fxName =

99 effectList fxName =

94 Env.getType env "List" <|

100 Env.getType env "List" <|

src/Type/Constrain/Expression.hs+19−15

@@ -1,9 +1,12 @@

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module Type.Constrain.Expression where

3module Type.Constrain.Expression where

4import Control.Arrow (second)

5import Control.Arrow (second)

5import qualified Control.Monad as Monad

6import qualified Control.Monad as Monad

6import qualified Data.Map as Map

7import qualified Data.Map as Map

8+import qualified Data.Text as Text

9+import Data.Text (Text)

8import qualified AST.Expression.Canonical as C

11import qualified AST.Expression.Canonical as C

9import qualified AST.Literal as Lit

12import qualified AST.Literal as Lit

@@ -45,20 +48,20 @@ constrain env annotatedExpr@(A.A region expression) tipe =

45 C.SaveEnv moduleName effects ->

48 C.SaveEnv moduleName effects ->

46 Effects.constrain env moduleName effects

49 Effects.constrain env moduleName effects

48− C.GLShader _uid _src gltipe ->

51+ C.GLShader _uid _src glType ->

49 exists $ \attr ->

52 exists $ \attr ->

50 exists $ \unif ->

53 exists $ \unif ->

51 let

54 let

52 shaderTipe a u v =

55 shaderTipe a u v =

53 Env.getType env "WebGL.Shader" <| a <| u <| v

56 Env.getType env "WebGL.Shader" <| a <| u <| v

55− glToType glTipe =

58+ glToType gl =

56− Env.getType env (Lit.glTipeName glTipe)

59+ Env.getType env (Lit.glTypeToText gl)

58 makeRec accessor baseRec =

61 makeRec accessor baseRec =

59− let decls = accessor gltipe

62+ let decls = accessor glType

60 in

63 in

61− if Map.size decls == 0 then

64+ if Map.null decls then

62 baseRec

65 baseRec

63 else

66 else

64 record (Map.map glToType decls) baseRec

67 record (Map.map glToType decls) baseRec

@@ -70,7 +73,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

70 return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

73 return (CEqual Error.Shader region (shaderTipe attribute uniform varying) tipe)

72 C.Var var ->

75 C.Var var ->

73− return (CInstance region (V.toString var) tipe)

76+ return (CInstance region (V.toText var) tipe)

75 C.List exprs ->

78 C.List exprs ->

76 constrainList env region exprs tipe

79 constrainList env region exprs tipe

@@ -103,7 +106,7 @@ constrain env annotatedExpr@(A.A region expression) tipe =

103 do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

106 do vars <- Monad.forM exprs $ \_ -> mkVar Nothing

104 let pairs = zip exprs (map VarN vars)

107 let pairs = zip exprs (map VarN vars)

105 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

108 (ctipe, cs) <- Monad.foldM step (tipe, CTrue) (reverse pairs)

106− return $ ex vars (cs /\ CInstance region name ctipe)

109+ return $ ex vars (cs /\ CInstance region (V.toText name) ctipe)

107 where

110 where

108 step (t,c) (e,x) =

111 step (t,c) (e,x) =

109 do c' <- constrain env e x

112 do c' <- constrain env e x

@@ -270,7 +273,7 @@ constrainBinop env region op leftExpr@(A.A leftRegion _) rightExpr@(A.A rightReg

270 ex [leftVar,rightVar,leftVar',rightVar',answerVar] $ CAnd $

273 ex [leftVar,rightVar,leftVar',rightVar',answerVar] $ CAnd $

271 [ leftCon

274 [ leftCon

272 , rightCon

275 , rightCon

273− , CInstance region (V.toString op) opType

276+ , CInstance region (V.toText op) opType

274 , CEqual (Error.BinopLeft op leftRegion) region (VarN leftVar') (VarN leftVar)

277 , CEqual (Error.BinopLeft op leftRegion) region (VarN leftVar') (VarN leftVar)

275 , CEqual (Error.BinopRight op rightRegion) region (VarN rightVar') (VarN rightVar)

278 , CEqual (Error.BinopRight op rightRegion) region (VarN rightVar') (VarN rightVar)

276 , CEqual (Error.Binop op) region (VarN answerVar) tipe

279 , CEqual (Error.Binop op) region (VarN answerVar) tipe

@@ -460,7 +463,7 @@ expandPattern def@(C.Def facts lpattern expr maybeType) =

460 P.boundVarList lpattern

463 P.boundVarList lpattern

461

464

462 combinedName =

465 combinedName =

463− "$" ++ concat vars

466+ Text.intercalate "$" ("" : vars)

464

467

465 pvar name =

468 pvar name =

466 A.A patternRegion (P.Var name)

469 A.A patternRegion (P.Var name)

@@ -483,11 +486,12 @@ expandPattern def@(C.Def facts lpattern expr maybeType) =

483-- CONSTRAIN DEFINITIONS

486-- CONSTRAIN DEFINITIONS

484

487

485

488

486−data Info = Info

489+data Info =

490+ Info

487 { iSchemes :: [TypeScheme]

491 { iSchemes :: [TypeScheme]

488 , iRigid :: [Variable]

492 , iRigid :: [Variable]

489 , iFlex :: [Variable]

493 , iFlex :: [Variable]

490− , iHeaders :: Map.Map String (A.Located Type)

494+ , iHeaders :: Map.Map Text (A.Located Type)

491 , iC2 :: TypeConstraint

495 , iC2 :: TypeConstraint

492 , iC1 :: TypeConstraint

496 , iC1 :: TypeConstraint

493 }

497 }

@@ -509,7 +513,7 @@ constrainDef env info (C.Def defRegion (A.A patternRegion pattern) expr maybeTip

509constrainUnannotatedDef

513constrainUnannotatedDef

510 :: Env.Env

514 :: Env.Env

511 -> R.Region

515 -> R.Region

512− -> String

516+ -> Text

513 -> C.Expr

517 -> C.Expr

514 -> Info

518 -> Info

515 -> IO Info

519 -> IO Info

@@ -528,7 +532,7 @@ constrainAnnotatedDef

528 :: Env.Env

532 :: Env.Env

529 -> R.Region

533 -> R.Region

530 -> R.Region

534 -> R.Region

531− -> String

535+ -> Text

532 -> C.Expr

536 -> C.Expr

533 -> ST.Canonical

537 -> ST.Canonical

534 -> Info

538 -> Info

@@ -554,7 +558,7 @@ constrainAnnotatedDef env defRegion region name expr tipe info =

554

558

555data ArgInfo =

559data ArgInfo =

556 ArgInfo

560 ArgInfo

557− { _name :: String

561+ { _name :: Text

558 , _def :: R.Region

562 , _def :: R.Region

559 , _env :: Env.Env

563 , _env :: Env.Env

560 , _args :: [(P.Canonical, Type)]

564 , _args :: [(P.Canonical, Type)]

@@ -594,7 +598,7 @@ constrainAnnDefHelp expr tipe (ArgInfo name defRegion env args vars) =

594 let sharedArity = length args

598 let sharedArity = length args

595 let typeArity = sharedArity + length (ST.collectLambdas tipe) - 1

599 let typeArity = sharedArity + length (ST.collectLambdas tipe) - 1

596 let argsArity = sharedArity + length (fst (C.collectLambdas expr))

600 let argsArity = sharedArity + length (fst (C.collectLambdas expr))

597− let hint = Error.ReturnType name typeArity argsArity region

601+ let hint = Error.ReturnType (Text.unpack name) typeArity argsArity region

598 let resultCon =

602 let resultCon =

599 CEqual hint defRegion rigidType resultType

603 CEqual hint defRegion rigidType resultType

600

604

src/Type/Constrain/Literal.hs+8−2

@@ -1,3 +1,5 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

1module Type.Constrain.Literal where

3module Type.Constrain.Literal where

3import qualified AST.Literal as L

5import qualified AST.Literal as L

@@ -7,13 +9,17 @@ import qualified Type.Type as T

7import qualified Type.Environment as Env

9import qualified Type.Environment as Env

12+

13+-- CONSTRAIN LITERALS

14+

15+

10constrain :: Env.Env -> R.Region -> L.Literal -> T.Type -> IO T.TypeConstraint

16constrain :: Env.Env -> R.Region -> L.Literal -> T.Type -> IO T.TypeConstraint

11constrain env region literal tipe =

17constrain env region literal tipe =

12 do definiteType <- litType

18 do definiteType <- litType

13 return (T.CEqual (Error.Literal name) region definiteType tipe)

19 return (T.CEqual (Error.Literal name) region definiteType tipe)

14 where

20 where

15− prim name =

21+ prim tipeName =

16− return (Env.getType env name)

22+ return (Env.getType env tipeName)

18 (name, litType) =

24 (name, litType) =

19 case literal of

25 case literal of

src/Type/Constrain/Pattern.hs+8−9

@@ -3,11 +3,12 @@ module Type.Constrain.Pattern (Info(..), joinInfos, infoToScheme, constrain) whe

4import Control.Arrow (second)

5import qualified Control.Monad as Monad

6−import qualified Data.List as List

7import qualified Data.Map as Map

6import qualified Data.Map as Map

7+import qualified Data.List as List

8+import Data.Text (Text)

9import qualified AST.Pattern as P

10import qualified AST.Pattern as P

10−import qualified AST.Variable as V

11+import qualified AST.Variable as Var

11import qualified Reporting.Annotation as A

12import qualified Reporting.Annotation as A

12import qualified Reporting.Error.Type as Error

13import qualified Reporting.Error.Type as Error

13import qualified Type.Constrain.Literal as Literal

14import qualified Type.Constrain.Literal as Literal

@@ -21,7 +22,7 @@ import Type.Type

22data Info =

23data Info =

23 Info

24 Info

24− { _headers :: Map.Map String (A.Located Type)

25+ { _headers :: Map.Map Text (A.Located Type)

25 , _vars :: [Variable]

26 , _vars :: [Variable]

26 , _cons :: TypeConstraint

27 , _cons :: TypeConstraint

27 }

28 }

@@ -91,18 +92,16 @@ constrain env (A.A region pattern) tipe =

91 /\ _cons info

92 /\ _cons info

92 }

93 }

94− P.Data name patterns ->

95+ P.Ctor name patterns ->

95− do let stringName = V.toString name

96−

97− (_kind, cvars, args, result) <-

96+ do (_kind, cvars, args, result) <-

98− Env.freshDataScheme env stringName

97+ Env.freshDataScheme env (Var.toText name)

100 fragList <- Monad.zipWithM (constrain env) patterns args

99 fragList <- Monad.zipWithM (constrain env) patterns args

101 let info = joinInfos fragList

100 let info = joinInfos fragList

102 return $ info

101 return $ info

103 { _vars = cvars ++ _vars info

102 { _vars = cvars ++ _vars info

104 , _cons =

103 , _cons =

105− equal (Error.PData stringName) result tipe

104+ equal (Error.PCtor name) result tipe

106 /\ _cons info

105 /\ _cons info

107 }

106 }

108

107

src/Type/Environment.hs+116−90

@@ -1,147 +1,180 @@

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module Type.Environment

3module Type.Environment

3 ( Env

4 ( Env

5+ , Dict

4 , initialize

6 , initialize

5− , getType, freshDataScheme, ctorNames

7+ , get, getType, freshDataScheme, ctorNames

6 , addValues

8 , addValues

7 , instantiateType

9 , instantiateType

8 )

10 )

9 where

11 where

13+import Control.Monad (foldM)

11import qualified Control.Monad.State as State

14import qualified Control.Monad.State as State

12−import Data.Map ((!))

15+import qualified Data.List as List

13import qualified Data.Map as Map

16import qualified Data.Map as Map

14import qualified Data.Set as Set

17import qualified Data.Set as Set

18+import qualified Data.Text as Text

19+import Data.Text (Text)

16import qualified AST.Type as T

21import qualified AST.Type as T

17−import qualified AST.Variable as V

22+import qualified AST.Variable as Var

18import qualified AST.Module as Module

23import qualified AST.Module as Module

19import Type.Type

24import Type.Type

22−type TypeDict = Map.Map String Type

23−type VarDict = Map.Map String Variable

28+-- ENVIRONMENT

30+

26−data Env = Env

31+data Env =

27− { _constructor :: Map.Map String (IO (Int, [Variable], [Type], Type))

32+ Env

33+ { _ctor :: Dict Instantiator

28− , _types :: TypeDict

34+ , _types :: Dict Type

29− , _value :: TypeDict

35+ , _value :: Dict Type

30 }

36 }

39+type Instantiator =

40+ IO (Int, [Variable], [Type], Type)

41+

42+

43+type Dict a =

44+ Map.Map Text a

45+

46+

33initialize :: [Module.CanonicalUnion] -> IO Env

47initialize :: [Module.CanonicalUnion] -> IO Env

34−initialize datatypes =

48+initialize unions =

35− do types <- makeTypes datatypes

49+ do types <- makeTypes unions

36 let env =

50 let env =

37 Env

51 Env

38− { _constructor = Map.empty

52+ { _ctor = Map.empty

39 , _value = Map.empty

53 , _value = Map.empty

40 , _types = types

54 , _types = types

41 }

55 }

42− return $ env { _constructor = makeConstructors env datatypes }

56+ return $ env { _ctor = makeCtors env unions }

45−makeTypes :: [Module.CanonicalUnion] -> IO TypeDict

46−makeTypes datatypes =

47− do unions <- mapM makeImported datatypes

48− bs <- mapM makeBuiltin builtins

49− return (Map.fromList (unions ++ bs))

50− where

51− makeImported :: (V.Canonical, Module.UnionInfo V.Canonical) -> IO (String, Type)

52− makeImported (name, _) =

53− do tvar <- mkAtom name

54− return (V.toString name, VarN tvar)

56− makeBuiltin :: (String, Int) -> IO (String, Type)

60+-- TYPES

57− makeBuiltin (name, _) =

58− do name' <- mkAtom (V.builtin name)

59− return (name, VarN name')

61− builtins :: [(String, Int)]

62+

62− builtins =

63+makeTypes :: [Module.CanonicalUnion] -> IO (Dict Type)

64+makeTypes unions =

65+ do builtinDict <- Map.fromList <$> mapM makeBuiltin builtinTypes

66+ foldM addImported builtinDict unions

67+

68+

69+addImported :: Dict Type -> (Var.Canonical, unionInfo) -> IO (Dict Type)

70+addImported dict ( var, _ ) =

71+ do atom <- mkAtom var

72+ return (Map.insert (Var.toText var) (VarN atom) dict)

73+

74+

75+makeBuiltin :: (Text, Int) -> IO (Text, Type)

76+makeBuiltin (name, _) =

77+ do atom <- mkAtom (Var.builtin name)

78+ return (name, VarN atom)

79+

80+

81+builtinTypes :: [(Text, Int)]

82+builtinTypes =

63− concat

83+ concat

64− [ map tuple [0..9]

84+ [ map tuple [0..9]

65− , kind 1 ["List"]

85+ , kind 1 ["List"]

66− , kind 0 ["Int","Float","Char","String","Bool"]

86+ , kind 0 ["Int","Float","Char","String","Bool"]

67− ]

87+ ]

68− where

69− tuple n = ("_Tuple" ++ show n, n)

70− kind n names = map (\name -> (name, n)) names

71−

72−

73−makeConstructors

74− :: Env

75− -> [Module.CanonicalUnion]

76− -> Map.Map String (IO (Int, [Variable], [Type], Type))

77−makeConstructors env datatypes =

78− Map.fromList builtins

79 where

88 where

89+ tuple n = ( Text.pack ("_Tuple" ++ show n), n )

90+ kind n names = map (\name -> (name, n)) names

91+

92+

93+

94+-- CONSTRUCTORS

95+

96+

97+makeCtors :: Env -> [Module.CanonicalUnion] -> Dict Instantiator

98+makeCtors env unions =

99+ let

80 list t =

100 list t =

81− (_types env ! "List") <| t

101+ getType env "List" <| t

102

83− inst :: Int -> ([Type] -> ([Type], Type)) -> IO (Int, [Variable], [Type], Type)

103+ inst :: Int -> ([Type] -> ([Type], Type)) -> Instantiator

84 inst numTVars tipe =

104 inst numTVars tipe =

85 do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]

105 do vars <- mapM (\_ -> mkVar Nothing) [1..numTVars]

86 let (args, result) = tipe (map (VarN) vars)

106 let (args, result) = tipe (map (VarN) vars)

87 return (length args, vars, args, result)

107 return (length args, vars, args, result)

108

89 tupleCtor n =

109 tupleCtor n =

110+ let

111+ name =

90− let name = "_Tuple" ++ show n

112+ Text.pack ("_Tuple" ++ show n)

113+ in

91− in (name, inst n $ \vs -> (vs, foldl (<|) (_types env ! name) vs))

114+ (name, inst n $ \vs -> (vs, foldl (<|) (getType env name) vs))

115

93− builtins :: [ (String, IO (Int, [Variable], [Type], Type)) ]

116+ builtins :: Dict Instantiator

94 builtins =

117 builtins =

118+ Map.fromList $

95 [ ("[]", inst 1 $ \ [t] -> ([], list t))

119 [ ("[]", inst 1 $ \ [t] -> ([], list t))

96 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))

120 , ("::", inst 1 $ \ [t] -> ([t, list t], list t))

121+ ]

97− ] ++ map tupleCtor [0..9]

122+ ++ map tupleCtor [0..9]

98− ++ concatMap (ctorToType env) datatypes

123+ in

124+ List.foldl' (makeCtorsHelp env) builtins unions

125

100

126

101−ctorToType

127+type VarDict =

102− :: Env

128+ Map.Map Text Variable

103− -> (V.Canonical, Module.UnionInfo V.Canonical)

104− -> [(String, IO (Int, [Variable], [Type], Type))]

105−ctorToType env (name, (tvars, ctors)) =

106− zip (map (V.toString . fst) ctors) (map inst ctors)

107− where

108− inst :: (V.Canonical, [T.Canonical]) -> IO (Int, [Variable], [Type], Type)

109− inst ctor =

110− do ((args, tipe), dict) <- State.runStateT (go ctor) Map.empty

111− return (length args, Map.elems dict, args, tipe)

112

129

113

130

131+makeCtorsHelp :: Env -> Dict Instantiator -> Module.CanonicalUnion -> Dict Instantiator

132+makeCtorsHelp env constructorDict ( var, (rawTypeVars, ctors) ) =

133+ let

134+ inst :: Dict Instantiator -> (Var.Canonical, [T.Canonical]) -> Dict Instantiator

135+ inst ctorDict (name, rawArgs) =

136+ Map.insert

137+ (Var.toText name)

138+ ( do ((args, tipe), dict) <- State.runStateT (go rawArgs) Map.empty

139+ return ( length args, Map.elems dict, args, tipe )

140+ )

141+ ctorDict

142+

143+ tvars =

144+ map T.Var rawTypeVars

145+

114− go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)

146+ go :: [T.Canonical] -> State.StateT VarDict IO ([Type], Type)

115− go (_, args) =

147+ go args =

116 do types <- mapM (instantiator Flex env) args

148 do types <- mapM (instantiator Flex env) args

117− returnType <- instantiator Flex env (T.App (T.Type name) (map T.Var tvars))

149+ returnType <- instantiator Flex env (T.App (T.Type var) tvars)

118 return (types, returnType)

150 return (types, returnType)

151+ in

152+ List.foldl' inst constructorDict ctors

119

153

120

154

121

155

122-- ACCESS TYPES

156-- ACCESS TYPES

123

157

124

158

125−get :: (Env -> Map.Map String a) -> Env -> String -> a

159+{-# INLINE get #-}

126−get subDict env key =

160+get :: Dict a -> Text -> a

127− Map.findWithDefault (error msg) key (subDict env)

161+get dict var =

128− where

162+ dict Map.! var

129− msg = "Could not find type constructor `" ++ key ++ "` while checking types."

130

163

131

164

132−getType :: Env -> String -> Type

165+getType :: Env -> Text -> Type

133−getType =

166+getType env var =

134− get _types

167+ get (_types env) var

135

168

136

169

137−freshDataScheme :: Env -> String -> IO (Int, [Variable], [Type], Type)

170+freshDataScheme :: Env -> Text -> Instantiator

138−freshDataScheme =

171+freshDataScheme env var =

139− get _constructor

172+ get (_ctor env) var

140

173

141

174

142−ctorNames :: Env -> [String]

175+ctorNames :: Env -> [Text]

143ctorNames env =

176ctorNames env =

144− Map.keys (_constructor env)

177+ Map.keys (_ctor env)

145

178

146

179

147

180

@@ -167,7 +200,7 @@ instantiator flex env sourceType =

167 instantiatorHelp flex env Set.empty sourceType

200 instantiatorHelp flex env Set.empty sourceType

168

201

169

202

170−instantiatorHelp :: Flex -> Env -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type

203+instantiatorHelp :: Flex -> Env -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type

171instantiatorHelp flex env aliasVars sourceType =

204instantiatorHelp flex env aliasVars sourceType =

172 let

205 let

173 go =

206 go =

@@ -198,7 +231,7 @@ instantiatorHelp flex env aliasVars sourceType =

198 return (VarN variable)

231 return (VarN variable)

199

232

200 T.Aliased name args aliasType ->

233 T.Aliased name args aliasType ->

201− do targs <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args

234+ do targs <- traverse (traverse go) args

202 realType <-

235 realType <-

203 case aliasType of

236 case aliasType of

204 T.Filled tipe ->

237 T.Filled tipe ->

@@ -210,18 +243,11 @@ instantiatorHelp flex env aliasVars sourceType =

210 return (AliasN name targs realType)

243 return (AliasN name targs realType)

211

244

212 T.Type name ->

245 T.Type name ->

213− case Map.lookup (V.toString name) (_types env) of

246+ return (getType env (Var.toText name))

214− Just tipe ->

215− return tipe

216−

217− Nothing ->

218− error $

219− "Could not find type constructor `" ++

220− V.toString name ++ "` while checking types."

221

247

222 T.App func args ->

248 T.App func args ->

223 do tfunc <- go func

249 do tfunc <- go func

224− targs <- mapM go args

250+ targs <- traverse go args

225 return $ foldl (<|) tfunc targs

251 return $ foldl (<|) tfunc targs

226

252

227 T.Record fields ext ->

253 T.Record fields ext ->

src/Type/Inference.hs+14−11

@@ -1,9 +1,11 @@

1+{-# LANGUAGE OverloadedStrings #-}

1module Type.Inference where

2module Type.Inference where

3import Control.Arrow (first, second)

4import Control.Arrow (first, second)

4import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)

5import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)

5import qualified Data.Map as Map

6import qualified Data.Map as Map

6−import qualified Data.Traversable as Traverse

7+import Data.Monoid ((<>))

8+import Data.Text (Text)

8import qualified AST.Module as Module

10import qualified AST.Module as Module

9import qualified AST.Module.Name as ModuleName

11import qualified AST.Module.Name as ModuleName

@@ -25,7 +27,7 @@ import System.IO.Unsafe

25infer

27infer

26 :: Module.Interfaces

28 :: Module.Interfaces

27 -> Module.Canonical

29 -> Module.Canonical

28− -> Except [A.Located Error.Error] (Map.Map String Type.Canonical)

30+ -> Except [A.Located Error.Error] (Map.Map Text Type.Canonical)

29infer interfaces modul =

31infer interfaces modul =

30 either throwError return $ unsafePerformIO $ runExceptT $

32 either throwError return $ unsafePerformIO $ runExceptT $

31 do (header, constraint) <-

33 do (header, constraint) <-

@@ -36,15 +38,16 @@ infer interfaces modul =

36 let header' = Map.delete "::" header

38 let header' = Map.delete "::" header

37 let types = Map.map A.drop (Map.difference (TS.sSavedEnv state) header')

39 let types = Map.map A.drop (Map.difference (TS.sSavedEnv state) header')

39− liftIO (Traverse.traverse T.toSrcType types)

41+ liftIO (traverse T.toSrcType types)

42genConstraints

44genConstraints

43 :: Module.Interfaces

45 :: Module.Interfaces

44 -> Module.Canonical

46 -> Module.Canonical

45− -> IO (Map.Map String T.Type, T.TypeConstraint)

47+ -> IO (Map.Map Text T.Type, T.TypeConstraint)

46genConstraints interfaces modul =

48genConstraints interfaces modul =

49+ do env <-

47− do env <- Env.initialize (canonicalizeUnions interfaces modul)

50+ Env.initialize (canonicalizeUnions interfaces modul)

49 ctors <-

52 ctors <-

50 forM (Env.ctorNames env) $ \name ->

53 forM (Env.ctorNames env) $ \name ->

@@ -70,12 +73,12 @@ genConstraints interfaces modul =

70canonicalizeValues

73canonicalizeValues

71 :: Env.Env

74 :: Env.Env

72 -> (ModuleName.Canonical, Module.Interface)

75 -> (ModuleName.Canonical, Module.Interface)

73− -> IO [(String, ([T.Variable], T.Type))]

76+ -> IO [(Text, ([T.Variable], T.Type))]

74canonicalizeValues env (moduleName, iface) =

77canonicalizeValues env (moduleName, iface) =

75 forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->

78 forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->

76 do (flexType, flexVars) <- Env.instantiateType T.Flex env tipe

79 do (flexType, flexVars) <- Env.instantiateType T.Flex env tipe

77 return

80 return

78− ( ModuleName.canonicalToString moduleName ++ "." ++ name

81+ ( ModuleName.canonicalToText moduleName <> "." <> name

79 , ( Map.elems flexVars

82 , ( Map.elems flexVars

80 , flexType

83 , flexType

81 )

84 )

@@ -96,15 +99,15 @@ canonicalizeUnions interfaces (Module.Module name _ info) =

100

98format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]

101format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]

99−format (home, adts) =

102+format (home, unions) =

100− map canonical (Map.toList adts)

103+ map canonical (Map.toList unions)

101 where

104 where

102− canonical :: (String, Module.UnionInfo String) -> Module.CanonicalUnion

105+ canonical :: (Text, Module.UnionInfo Text) -> Module.CanonicalUnion

103 canonical (name, (tvars, ctors)) =

106 canonical (name, (tvars, ctors)) =

104 ( toVar name

107 ( toVar name

105 , (tvars, map (first toVar) ctors)

108 , (tvars, map (first toVar) ctors)

106 )

109 )

107

110

108− toVar :: String -> Var.Canonical

111+ toVar :: Text -> Var.Canonical

109 toVar name =

112 toVar name =

110 Var.fromModule home name

113 Var.fromModule home name

src/Type/Solve.hs+8−6

@@ -1,12 +1,13 @@

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module Type.Solve (solve) where

3module Type.Solve (solve) where

4import Control.Monad

5import Control.Monad

5import Control.Monad.State (execStateT, liftIO)

6import Control.Monad.State (execStateT, liftIO)

6import Control.Monad.Except (ExceptT, throwError)

7import Control.Monad.Except (ExceptT, throwError)

7−import qualified Data.List as List

8−import qualified Data.Map as Map

9import qualified Data.Foldable as F

8import qualified Data.Foldable as F

9+import qualified Data.Map as Map

10+import qualified Data.Text as Text

10import qualified Data.UnionFind.IO as UF

11import qualified Data.UnionFind.IO as UF

12import qualified Reporting.Annotation as A

13import qualified Reporting.Annotation as A

@@ -199,17 +200,17 @@ actuallySolve constraint =

199 TS.makeInstance tipe

200 TS.makeInstance tipe

200

201

201 Nothing ->

202 Nothing ->

202− if List.isPrefixOf "Native." name then

203+ if Text.isPrefixOf "Native." name then

203 liftIO (mkVar Nothing)

204 liftIO (mkVar Nothing)

204

205

205 else

206 else

206− error ("Could not find `" ++ name ++ "` when solving type constraints.")

207+ error ("Could not find `" ++ Text.unpack name ++ "` when solving type constraints.")

207

208

208 t <- TS.flatten term

209 t <- TS.flatten term

209 unify (Error.Instance name) region freshCopy t

210 unify (Error.Instance name) region freshCopy t

210

211

212

212−solveScheme :: TypeScheme -> TS.Solver (Map.Map String (A.Located Variable))

213+solveScheme :: TypeScheme -> TS.Solver TS.Env

213solveScheme scheme =

214solveScheme scheme =

214 let

215 let

215 flatten (A.A region term) =

216 flatten (A.A region term) =

@@ -238,6 +239,7 @@ solveScheme scheme =

238 return header'

239 return header'

239

240

241

242+

241-- ADDITIONAL CHECKS

243-- ADDITIONAL CHECKS

242

244

243

245

@@ -263,7 +265,7 @@ crash msg =

263-- OCCURS CHECK

265-- OCCURS CHECK

264

266

265

267

266−occurs :: (String, A.Located Variable) -> TS.Solver ()

268+occurs :: (Text.Text, A.Located Variable) -> TS.Solver ()

267occurs (name, A.A region variable) =

269occurs (name, A.A region variable) =

268 do hasOccurred <- liftIO $ occursHelp [] variable

270 do hasOccurred <- liftIO $ occursHelp [] variable

269 case hasOccurred of

271 case hasOccurred of

src/Type/State.hs+9−6

@@ -2,8 +2,9 @@

2module Type.State where

4import qualified Control.Monad.State as State

5−import Data.Map ((!))

6import qualified Data.Map as Map

5import qualified Data.Map as Map

6+import Data.Map ((!))

7+import Data.Text (Text)

7import qualified Data.UnionFind.IO as UF

8import qualified Data.UnionFind.IO as UF

9import qualified Reporting.Annotation as A

10import qualified Reporting.Annotation as A

@@ -17,7 +18,8 @@ import Type.Type

17-- The rank of each variable is less than or equal to the pool's "maxRank"

18-- The rank of each variable is less than or equal to the pool's "maxRank"

18-- The young pool exists to make it possible to identify these vars in constant time.

19-- The young pool exists to make it possible to identify these vars in constant time.

20−data Pool = Pool

21+data Pool =

22+ Pool

21 { maxRank :: Int

23 { maxRank :: Int

22 , inhabitants :: [Variable]

24 , inhabitants :: [Variable]

23 }

25 }

@@ -25,20 +27,21 @@ data Pool = Pool

26emptyPool :: Pool

28emptyPool :: Pool

27emptyPool =

29emptyPool =

28− Pool

30+ Pool

29 { maxRank = outermostRank

31 { maxRank = outermostRank

30 , inhabitants = []

32 , inhabitants = []

31 }

33 }

34−type Env = Map.Map String (A.Located Variable)

36+type Env = Map.Map Text (A.Located Variable)

37type Solver = State.StateT SolverState IO

39type Solver = State.StateT SolverState IO

40-- Keeps track of the environment, type variable pool, and a list of errors

42-- Keeps track of the environment, type variable pool, and a list of errors

41−data SolverState = SS

43+data SolverState =

44+ SS

42 { sEnv :: Env

45 { sEnv :: Env

43 , sSavedEnv :: Env

46 , sSavedEnv :: Env

44 , sPool :: Pool

47 , sPool :: Pool

@@ -126,7 +129,7 @@ flatten term =

126 flattenHelp Map.empty term

129 flattenHelp Map.empty term

127

130

128

131

129−flattenHelp :: Map.Map String Variable -> Type -> Solver Variable

132+flattenHelp :: Map.Map Text Variable -> Type -> Solver Variable

130flattenHelp aliasDict termN =

133flattenHelp aliasDict termN =

131 case termN of

134 case termN of

132 PlaceHolder name ->

135 PlaceHolder name ->

src/Type/Type.hs+37−29

@@ -1,13 +1,16 @@

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module Type.Type where

3module Type.Type where

4import Control.Monad (when)

5import Control.Monad (when)

5import Control.Monad.State (StateT, liftIO)

6import Control.Monad.State (StateT, liftIO)

6import qualified Control.Monad.State as State

7import qualified Control.Monad.State as State

7import qualified Data.Char as Char

8import qualified Data.Char as Char

8−import qualified Data.List as List

9import qualified Data.Map as Map

10+import Data.Monoid ((<>))

11+import qualified Data.Text as Text

10import qualified Data.UnionFind.IO as UF

12import qualified Data.UnionFind.IO as UF

13+import Data.Text (Text)

12import qualified AST.Type as T

15import qualified AST.Type as T

13import qualified AST.Variable as Var

16import qualified AST.Variable as Var

@@ -44,17 +47,17 @@ data Term1 a

44 = App1 a a

47 = App1 a a

45 | Fun1 a a

48 | Fun1 a a

46 | EmptyRecord1

49 | EmptyRecord1

47− | Record1 (Map.Map String a) a

50+ | Record1 (Map.Map Text a) a

50data TermN a

53data TermN a

51− = PlaceHolder String

54+ = PlaceHolder Text

52− | AliasN Var.Canonical [(String, TermN a)] (TermN a)

55+ | AliasN Var.Canonical [(Text, TermN a)] (TermN a)

53 | VarN a

56 | VarN a

54 | TermN (Term1 (TermN a))

57 | TermN (Term1 (TermN a))

57−record :: Map.Map String (TermN a) -> TermN a -> TermN a

60+record :: Map.Map Text (TermN a) -> TermN a -> TermN a

58record fs rec =

61record fs rec =

59 TermN (Record1 fs rec)

62 TermN (Record1 fs rec)

@@ -63,7 +66,8 @@ record fs rec =

63-- DESCRIPTORS

66-- DESCRIPTORS

66−data Descriptor = Descriptor

69+data Descriptor =

70+ Descriptor

67 { _content :: Content

71 { _content :: Content

68 , _rank :: Int

72 , _rank :: Int

69 , _mark :: Int

73 , _mark :: Int

@@ -74,8 +78,8 @@ data Descriptor = Descriptor

74data Content

78data Content

75 = Structure (Term1 Variable)

79 = Structure (Term1 Variable)

76 | Atom Var.Canonical

80 | Atom Var.Canonical

77− | Var Flex (Maybe Super) (Maybe String)

81+ | Var Flex (Maybe Super) (Maybe Text)

78− | Alias Var.Canonical [(String,Variable)] Variable

82+ | Alias Var.Canonical [(Text,Variable)] Variable

79 | Error

83 | Error

@@ -131,14 +135,14 @@ data Constraint a b

131 | CInstance R.Region SchemeName a

135 | CInstance R.Region SchemeName a

132

136

133

137

134−type SchemeName = String

138+type SchemeName = Text

135

139

136

140

137data Scheme a b = Scheme

141data Scheme a b = Scheme

138 { _rigidQuantifiers :: [b]

142 { _rigidQuantifiers :: [b]

139 , _flexibleQuantifiers :: [b]

143 , _flexibleQuantifiers :: [b]

140 , _constraint :: Constraint a b

144 , _constraint :: Constraint a b

141− , _header :: Map.Map String (A.Located a)

145+ , _header :: Map.Map Text (A.Located a)

142 }

146 }

143

147

144

148

@@ -183,20 +187,20 @@ mkVar maybeSuper =

183 UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)

187 UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)

184

188

185

189

186−mkNamedVar :: Flex -> String -> IO Variable

190+mkNamedVar :: Flex -> Text -> IO Variable

187mkNamedVar flex name =

191mkNamedVar flex name =

188 UF.fresh $ mkDescriptor $ Var flex (toSuper name) (Just name)

192 UF.fresh $ mkDescriptor $ Var flex (toSuper name) (Just name)

189

193

190

194

191−toSuper :: String -> Maybe Super

195+toSuper :: Text -> Maybe Super

192toSuper name =

196toSuper name =

193− if List.isPrefixOf "number" name then

197+ if Text.isPrefixOf "number" name then

194 Just Number

198 Just Number

195

199

196− else if List.isPrefixOf "comparable" name then

200+ else if Text.isPrefixOf "comparable" name then

197 Just Comparable

201 Just Comparable

198

202

199− else if List.isPrefixOf "appendable" name then

203+ else if Text.isPrefixOf "appendable" name then

200 Just Appendable

204 Just Appendable

201

205

202 else

206 else

@@ -207,13 +211,14 @@ toSuper name =

207-- CONSTRAINT HELPERS

211-- CONSTRAINT HELPERS

208

212

209

213

210−monoscheme :: Map.Map String (A.Located a) -> Scheme a b

214+monoscheme :: Map.Map Text (A.Located a) -> Scheme a b

211monoscheme headers =

215monoscheme headers =

212 Scheme [] [] CTrue headers

216 Scheme [] [] CTrue headers

213

217

214

218

215infixl 8 /\

219infixl 8 /\

216

220

221+

217(/\) :: Constraint a b -> Constraint a b -> Constraint a b

222(/\) :: Constraint a b -> Constraint a b -> Constraint a b

218(/\) c1 c2 =

223(/\) c1 c2 =

219 case (c1, c2) of

224 case (c1, c2) of

@@ -349,7 +354,7 @@ data NameState = NameState

349 }

354 }

350

355

351

356

352−type TakenNames = Map.Map String Variable

357+type TakenNames = Map.Map Text Variable

353

358

354

359

355makeNameState :: TakenNames -> NameState

360makeNameState :: TakenNames -> NameState

@@ -357,7 +362,7 @@ makeNameState taken =

357 NameState taken 0 0 0 0 0

362 NameState taken 0 0 0 0 0

358

363

359

364

360−getFreshName :: (Monad m) => Maybe Super -> StateT NameState m String

365+getFreshName :: (Monad m) => Maybe Super -> StateT NameState m Text

361getFreshName maybeSuper =

366getFreshName maybeSuper =

362 case maybeSuper of

367 case maybeSuper of

363 Nothing ->

368 Nothing ->

@@ -380,14 +385,17 @@ getFreshName maybeSuper =

380 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })

385 getFreshSuper "compappend" _compAppends (\index state -> state { _compAppends = index })

381

386

382

387

383−getFreshNormal :: Int -> TakenNames -> (String, Int)

388+getFreshNormal :: Int -> TakenNames -> (Text, Int)

384getFreshNormal index taken =

389getFreshNormal index taken =

385 let

390 let

386 (postfix, letter) =

391 (postfix, letter) =

387 quotRem index 26

392 quotRem index 26

388

393

394+ char =

395+ Char.chr (97 + letter)

396+

389 name =

397 name =

390− Char.chr (97 + letter) : if postfix <= 0 then "" else show postfix

398+ Text.pack (if postfix <= 0 then [char] else char : show postfix)

391 in

399 in

392 if Map.member name taken then

400 if Map.member name taken then

393 getFreshNormal (index + 1) taken

401 getFreshNormal (index + 1) taken

@@ -398,10 +406,10 @@ getFreshNormal index taken =

398

406

399getFreshSuper

407getFreshSuper

400 :: (Monad m)

408 :: (Monad m)

401− => String

409+ => Text

402 -> (NameState -> Int)

410 -> (NameState -> Int)

403 -> (Int -> NameState -> NameState)

411 -> (Int -> NameState -> NameState)

404− -> StateT NameState m String

412+ -> StateT NameState m Text

405getFreshSuper name getter setter =

413getFreshSuper name getter setter =

406 do index <- State.gets getter

414 do index <- State.gets getter

407 taken <- State.gets _taken

415 taken <- State.gets _taken

@@ -410,11 +418,11 @@ getFreshSuper name getter setter =

410 return uniqueName

418 return uniqueName

411

419

412

420

413−getFreshSuperHelp :: String -> Int -> TakenNames -> (String, Int)

421+getFreshSuperHelp :: Text -> Int -> TakenNames -> (Text, Int)

414getFreshSuperHelp name index taken =

422getFreshSuperHelp name index taken =

415 let

423 let

416 newName =

424 newName =

417− if index <= 0 then name else name ++ show index

425+ if index <= 0 then name else name <> Text.pack (show index)

418 in

426 in

419 if Map.member newName taken then

427 if Map.member newName taken then

420 getFreshSuperHelp name (index + 1) taken

428 getFreshSuperHelp name (index + 1) taken

@@ -471,7 +479,7 @@ getVarNames var =

471 getVarNames extension

479 getVarNames extension

472

480

473

481

474−addVarName :: Int -> String -> Variable -> Flex -> Maybe Super -> TakenNames -> IO TakenNames

482+addVarName :: Int -> Text -> Variable -> Flex -> Maybe Super -> TakenNames -> IO TakenNames

475addVarName index givenName var flex maybeSuper taken =

483addVarName index givenName var flex maybeSuper taken =

476 let

484 let

477 name =

485 name =

@@ -490,13 +498,13 @@ addVarName index givenName var flex maybeSuper taken =

490 else addVarName (index + 1) givenName var flex maybeSuper taken

498 else addVarName (index + 1) givenName var flex maybeSuper taken

491

499

492

500

493−makeIndexedName :: String -> Int -> String

501+makeIndexedName :: Text -> Int -> Text

494makeIndexedName name index =

502makeIndexedName name index =

495 if index <= 0 then

503 if index <= 0 then

496 name

504 name

497

505

498− else if Char.isDigit (last name) then

506+ else if Char.isDigit (Text.last name) then

499− name ++ '_' : show index

507+ name <> Text.pack ('_' : show index)

500

508

501 else

509 else

502− name ++ show index

510+ name <> Text.pack (show index)

src/Type/Unify.hs+12−9

@@ -1,10 +1,13 @@

1{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

2module Type.Unify (unify) where

3module Type.Unify (unify) where

4import Control.Monad (zipWithM_)

5import Control.Monad (zipWithM_)

5import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)

6import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)

6import qualified Data.Map as Map

7import qualified Data.Map as Map

7import qualified Data.Maybe as Maybe

8import qualified Data.Maybe as Maybe

9+import qualified Data.Text as Text

10+import Data.Text (Text)

8import qualified Data.UnionFind.IO as UF

11import qualified Data.UnionFind.IO as UF

10import qualified AST.Variable as Var

13import qualified AST.Variable as Var

@@ -103,7 +106,7 @@ mismatchHelp orientation maybeReason =

103 Error.flipReason <$> maybeReason

106 Error.flipReason <$> maybeReason

104

107

105

108

106−badRigid :: Maybe String -> Error.Reason

109+badRigid :: Maybe Text -> Error.Reason

107badRigid maybeName =

110badRigid maybeName =

108 Error.BadVar (Just (Error.Rigid maybeName)) Nothing

111 Error.BadVar (Just (Error.Rigid maybeName)) Nothing

109

112

@@ -248,7 +251,7 @@ unifyFlex context otherContent =

248-- UNIFY RIGID VARIABLES

251-- UNIFY RIGID VARIABLES

249

252

250

253

251−unifyRigid :: Context -> Maybe Super -> Maybe String -> Content -> Unify ()

254+unifyRigid :: Context -> Maybe Super -> Maybe Text -> Content -> Unify ()

252unifyRigid context maybeSuper maybeName otherContent =

255unifyRigid context maybeSuper maybeName otherContent =

253 case otherContent of

256 case otherContent of

254 Error ->

257 Error ->

@@ -353,7 +356,7 @@ combineSupers firstSuper secondSuper =

353 Left $ doubleBad (errorSuper firstSuper) (errorSuper secondSuper)

356 Left $ doubleBad (errorSuper firstSuper) (errorSuper secondSuper)

354

357

355

358

356−isPrimitiveFrom :: [String] -> Var.Canonical -> Bool

359+isPrimitiveFrom :: [Text] -> Var.Canonical -> Bool

357isPrimitiveFrom prims var =

360isPrimitiveFrom prims var =

358 any (\p -> Var.isPrim p var) prims

361 any (\p -> Var.isPrim p var) prims

359

362

@@ -531,7 +534,7 @@ isIntFloat name otherName =

531-- UNIFY ALIASES

534-- UNIFY ALIASES

532

535

533

536

534−unifyAlias :: Context -> Var.Canonical -> [(String, Variable)] -> Variable -> Content -> Unify ()

537+unifyAlias :: Context -> Var.Canonical -> [(Text, Variable)] -> Variable -> Content -> Unify ()

535unifyAlias context name args realVar otherContent =

538unifyAlias context name args realVar otherContent =

536 case otherContent of

539 case otherContent of

537 Error ->

540 Error ->

@@ -668,7 +671,7 @@ unifyRecord context firstStructure secondStructure =

668

671

669

672

670

673

671−unifySharedFieldsHelp :: Context -> Map.Map String (Variable, Variable) -> Unify ()

674+unifySharedFieldsHelp :: Context -> Map.Map Text (Variable, Variable) -> Unify ()

672unifySharedFieldsHelp context sharedFields =

675unifySharedFieldsHelp context sharedFields =

673 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)

676 do maybeBadFields <- traverse (unifyField context) (Map.toList sharedFields)

674 case Maybe.catMaybes maybeBadFields of

677 case Maybe.catMaybes maybeBadFields of

@@ -679,7 +682,7 @@ unifySharedFieldsHelp context sharedFields =

679 mismatch context (Just (Error.BadFields (reverse badFields)))

682 mismatch context (Just (Error.BadFields (reverse badFields)))

680

683

681

684

682−unifyField :: Context -> (String, (Variable, Variable)) -> Unify (Maybe (String, Maybe Error.Reason))

685+unifyField :: Context -> (Text, (Variable, Variable)) -> Unify (Maybe (String, Maybe Error.Reason))

683unifyField context (field, (expected, actual)) =

686unifyField context (field, (expected, actual)) =

684 do result <- lift $ runExceptT $ subUnify context expected actual

687 do result <- lift $ runExceptT $ subUnify context expected actual

685 case result of

688 case result of

@@ -687,7 +690,7 @@ unifyField context (field, (expected, actual)) =

687 return $ Nothing

690 return $ Nothing

688

691

689 Left (Mismatch maybeReason) ->

692 Left (Mismatch maybeReason) ->

690− return $ Just (field, maybeReason)

693+ return $ Just (Text.unpack field, maybeReason)

691

694

692

695

693

696

@@ -695,7 +698,7 @@ unifyField context (field, (expected, actual)) =

695

698

696

699

697data RecordStructure = RecordStructure

700data RecordStructure = RecordStructure

698− { _fields :: Map.Map String Variable

701+ { _fields :: Map.Map Text Variable

699 , _extVar :: Variable

702 , _extVar :: Variable

700 , _extStruct :: ExtensionStructure

703 , _extStruct :: ExtensionStructure

701 }

704 }

@@ -706,7 +709,7 @@ data ExtensionStructure

706 | Extension

709 | Extension

707

710

708

711

709−gatherFields :: Context -> Map.Map String Variable -> Variable -> Unify RecordStructure

712+gatherFields :: Context -> Map.Map Text Variable -> Variable -> Unify RecordStructure

710gatherFields context fields variable =

713gatherFields context fields variable =

711 do desc <- liftIO (UF.descriptor variable)

714 do desc <- liftIO (UF.descriptor variable)

712 case _content desc of

715 case _content desc of