9e90c58 · elk · git.iko.soy

git.iko.soy/elk

Change module names in Types/ to include Types prefix. Work on getting let-polymorphism correct.

commit9e90c58849941de2e0b1ad753aeac311745183dc authorevancz <info@elm-lang.org> dateThu 9 Aug 2012, 16:38 (14 years ago) parent46df5ff

11 files changed+306−169

compare with master

unifiedsplit

elm/Elm.cabal+8−8 elm/src/Ast.hs+2−1 elm/src/Gen/CompileToJS.hs+3−6 elm/src/Initialize.hs+5−5 elm/src/Optimize.hs+8−8 elm/src/Rename.hs+6−2 elm/src/Types/Constrain.hs+64−52 elm/src/Types/Hints.hs+22−18 elm/src/Types/Substitutions.hs+98 elm/src/Types/Types.hs+22−13 elm/src/Types/Unify.hs+68−56

elm/Elm.cabal+8−8

@@ -50,10 +50,10 @@ Library

5050 ParseModules,

5151 ParseForeign,

5252 Types,

53− Constrain,

54− Hints,

55− Types,

56− Unify

53+ Types.Constrain,

54+ Types.Hints,

55+ Types.Substitutions,

56+ Types.Unify

5757

5858 Build-depends: base >=4.2 && <5,

5959 containers >= 0.3,

@@ -87,10 +87,10 @@ Executable elm

8787 ParseModules,

8888 ParseForeign,

8989 Types,

90− Constrain,

91− Hints,

92− Types,

93− Unify

90+ Types.Constrain,

91+ Types.Hints,

92+ Types.Substitutions,

93+ Types.Unify

9494

9595 Build-depends: base >=4.2 && <5,

9696 containers >= 0.3,

elm/src/Ast.hs+2−1

@@ -45,7 +45,7 @@ data Statement = Def String [String] Expr

4545 | Datatype String [X] [(String,[Type])]

4646 | ImportEvent String Expr String Type

4747 | ExportEvent String String Type

48− deriving (Eq)

48+ deriving (Eq,Show)

4949

5050cons h t = Data "Cons" [h,t]

5151nil = Data "Nil" []

@@ -100,6 +100,7 @@ instance Show Expr where

100100 show (Async e) = "async " ++ show' e

101101 show (Input i) = i

102102

103+

103104instance Show Definition where

104105 show (Definition v [] e) = v ++ " = " ++ show e

105106 show (Definition f args e) = f ++ " " ++ intercalate " " args ++ " = " ++ show e

elm/src/Gen/CompileToJS.hs+3−6

@@ -10,6 +10,7 @@ import Data.Map (toList)

1010import Data.Maybe (mapMaybe)

1111

1212import Initialize

13+import Rename (derename)

1314

1415showErr :: String -> String

1516showErr err = mainEquals $ "text(monospace(" ++ msg ++ "))"

@@ -56,14 +57,10 @@ jsModule (Module names exports imports stmts) =

5657 export = getExports exps stmts

5758 exps = if null exports then ["main"] else exports

5859

59−stripID var

60− | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var

61− | otherwise = var

62−

6360getExports names stmts = ret . braces $ intercalate "," pairs

6461 where pairs = mapMaybe pair $ concatMap get stmts

6562 pair x = if y `elem` names then Just $ y ++ ":" ++ x else Nothing

66− where y = stripID x

63+ where y = derename x

6764 get s = case s of Def x _ _ -> [x]

6865 Datatype _ _ tcs -> map fst tcs

6966 ImportEvent _ _ x _ -> [x]

@@ -102,7 +99,7 @@ stmtToJS (Def name [] e) = assign name (toJS e)

10299stmtToJS (Def name (a:as) e) = "\nfunction " ++ name ++ parens a ++

103100 braces (ret . toJS $ foldr Lambda e as) ++ ";"

104101stmtToJS (Datatype _ _ tcs) = concatMap (stmtToJS . toDef) tcs

105− where toDef (name,args) = Def name vars $ Data (stripID name) (map Var vars)

102+ where toDef (name,args) = Def name vars $ Data (derename name) (map Var vars)

106103 where vars = map (('a':) . show) [1..length args]

107104stmtToJS (ImportEvent js base elm _) =

108105 concat [ "\nvar " ++ elm ++ " = Elm.Input(" ++ toJS base ++ ");"

elm/src/Initialize.hs+5−5

@@ -6,18 +6,18 @@ import Data.List (lookup)

77import Ast

88import Parser (parseProgram)

9−import Hints (hints)

10−import Unify

119import Rename

1210import Types ((-:))

11+import Types.Hints (hints)

12+import Types.Unify

1313import Optimize

1414

1515

1616initialize str =

1717 let nameOf (Definition n _ _) = n in

18− do modul@(Module name ex im stmts) <- rename <$> parseProgram str

18+ do modul@(Module name ex im stmts) <- parseProgram str

1919 subs <- unify hints modul

20− let modul' = Module name ex im' stmts

20+ let modul' = optimize . rename $ Module name ex im' stmts

2121 where im' | any ((=="Prelude") . fst) im = im

2222 | otherwise = ("Prelude", Importing []) : im

23− subs `seq` return (optimize modul')

23+ subs `seq` return modul'

elm/src/Optimize.hs+8−8

@@ -32,11 +32,7 @@ simp expr =

3232simp_if (Boolean b) e2 e3 = if b then e2 else e3

3333simp_if a b c = If a b c

3434

35−simp_binop "mod" (IntNum n) (IntNum m) = IntNum (mod n m)

36−simp_binop "mod" e1 e2 = Binop "mod" e1 e2

37−simp_binop str e1 e2

38− | isAlpha (head str) || '_' == head str = App (App (Var str) e1) e2

39− | otherwise = binop str e1 e2

35+simp_binop = binop

4036

4137binop op (IntNum n) (IntNum m) = f n m

4238 where f a b = case op of

@@ -44,6 +40,7 @@ binop op (IntNum n) (IntNum m) = f n m

4440 ; "-" -> IntNum $ (-) a b

4541 ; "*" -> IntNum $ (*) a b

4642 ; "div" -> IntNum $ div a b

43+ ; "mod" -> IntNum $ mod a b

4744 ; "<" -> Boolean $ a < b

4845 ; ">" -> Boolean $ a < b

4946 ; "<=" -> Boolean $ a <= b

@@ -54,6 +51,7 @@ binop op (IntNum n) (IntNum m) = f n m

5451

5552binop "-" e (IntNum 0) = e

5653binop "+" (IntNum 0) e = e

54+binop "+" e (IntNum 0) = e

5755binop "+" (IntNum n) (Binop "+" (IntNum m) e) = binop "+" (IntNum (n+m)) e

5856binop "+" (IntNum n) (Binop "+" e (IntNum m)) = binop "+" (IntNum (n+m)) e

5957

@@ -77,7 +75,8 @@ binop "&&" (Boolean False) e = Boolean False

7775binop "||" (Boolean True) e = Boolean True

7876binop "||" (Boolean False) e = e

7977

80−binop op e (Boolean n) = binop op (Boolean n) e

78+binop "&&" e (Boolean n) = binop "&&" (Boolean n) e

79+binop "||" e (Boolean n) = binop "||" (Boolean n) e

8180

8281binop ":" h t = cons h t

8382binop "++" (Str s1) (Str s2) = Str $ s1 ++ s2

@@ -89,5 +88,6 @@ binop "++" (Data "Cons" [h,t]) e = Data "Cons" [h, binop "++" t e]

8988

9089binop "$" e1 e2 = App e1 e2

9190

92−binop op e1 e2 = Binop op e1 e2

93−--}

91+binop op e1 e2

92+ | isAlpha (head op) || '_' == head op = App (App (Var op) e1) e2

93+ | otherwise = Binop op e1 e2

elm/src/Rename.hs+6−2

@@ -1,13 +1,17 @@

11{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−module Rename (rename) where

2+module Rename (rename, derename) where

44import Ast

55import Control.Arrow (first)

66import Control.Monad (ap, liftM, foldM, mapM, Monad, zipWithM)

77import Control.Monad.State (evalState, State, get, put)

8−import Data.Char (isLower)

8+import Data.Char (isLower,isDigit)

99import Guid

1010

11+derename var

12+ | isDigit (last var) = reverse . tail . dropWhile isDigit $ reverse var

13+ | otherwise = var

14+

1115rename :: Module -> Module

1216rename (Module name ex im stmts) =

1317 Module name ex im . run $ renameStatements id stmts

elm/src/Types/Constrain.hs+64−52

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

2−module Constrain (constrain, Context (..)) where

2+module Types.Constrain (constrain) where

44import Ast

55import Types

@@ -7,28 +7,29 @@ import Data.List (foldl')

77import qualified Data.Set as Set

88import qualified Data.Map as Map

99import Control.Arrow (second)

10−import Control.Monad (liftM,mapM,zipWithM)

10+import Control.Monad (liftM,mapM,zipWithM,foldM)

1111import Control.Monad.State (evalState)

1212import Guid

13+import Types.Substitutions

14+

15+--import System.IO.Unsafe

16+

17+prints xs v = v --unsafePerformIO (putStrLn "~~~~~~~~~~" >> mapM print xs) `seq` v

1318

1419beta = VarT `liftM` guid

1520unionA = Map.unionWith (++)

1621unionsA = Map.unionsWith (++)

1722

18−data Context a b = Context a b deriving (Eq, Show)

19−ctx e = Context e

20−

21−instance (Ord a, Eq c) => Ord (Context c a) where

22− compare (Context _ x) (Context _ y) = compare x y

23−

2423constrain hints (Module _ _ _ stmts) = do

2524 (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts

26− let allHints = Map.fromList $ hints ++ concat schemess

27− let combine k s vs = map (\v -> ctx (Var k) $ VarT v :<<: s) vs

28− let cMap = Map.intersectionWithKey combine allHints (unionsA ass)

29− return (Set.toList (Set.unions css) ++ (concatMap snd $ Map.toList cMap))

25+ allHints <- liftM (Map.fromList . (++ concat schemess)) hints

26+ let insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as

27+ assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)

28+ let cs = let f k s vs = map (\v -> Context k $ v :<<: s) vs in

29+ concat . Map.elems $ Map.intersectionWithKey f allHints assumptions

30+ return $ cs ++ Set.toList (Set.unions css)

3031

31−gen :: Expr -> GuidCounter (Map.Map String [X], Set.Set (Context Expr Constraint), Type)

32+gen :: Expr -> GuidCounter (Map.Map String [X], Set.Set (Context String Constraint), Type)

3233

3334gen (Var x) =

3435 do b <- guid

@@ -56,7 +57,8 @@ gen (Let defs e) =

5657 let names = map (\(Definition x _ _) -> x) defs

5758 let genCs name s = do

5859 v <- guid

59− return . map (\x -> ctx (Var name) $ VarT x :<<: s) $ Map.findWithDefault [v] name assumptions

60+ let vs = Map.findWithDefault [v] name assumptions

61+ return $ map (\x -> ctx (Var name) $ x :<<: s) vs

6062 cs' <- zipWithM genCs names schemes

6163 return ( foldr Map.delete assumptions names

6264 , Set.union (Set.fromList . concat $ cs') cs

@@ -96,50 +98,62 @@ gen other =

9698primitive t = return (Map.empty, Set.empty, t)

9799

98100caseGen tipe (p,e) = do

99− (as,cs,t) <- gen e

100− return ( foldr Map.delete as (namesIn p)

101− , cs

102− , t)

103−

104−namesIn PAnything = []

105−namesIn (PVar v) = [v]

106−namesIn (PData name ps) = concatMap namesIn ps

107−

108−defScheme (Definition name args e) =

109− do argDict <- mapM (\a -> liftM ((,) a) guid) args

110− (as,cs,t) <- gen e

111− let genCs (arg,x) = do

112− v <- guid

113− return . map (\y -> VarT x :=: VarT y) $ Map.findWithDefault [v] arg as

114− cs' <- concat `liftM` mapM genCs argDict

115− let cs'' = map (\(Context _ c) -> c) (Set.toList cs)

116− let tipe = foldr (==>) t $ map (VarT . snd) argDict

117− return ( foldr Map.delete as args

118− , Forall (map snd argDict) (cs' ++ cs'') tipe)

119−

120−stmtGen (Def name args e) = do

101+ (as ,cs , t ) <- gen e

102+ (as',cs',[t']) <- patternGen (as,cs,[]) p

103+ let cs'' = Set.union cs' . Set.singleton . ctx p $ t' :=: tipe

104+ return ( as', cs'', t )

105+

106+patternGen (as,cs,ts) PAnything = ((,,) as cs . (\t -> ts++[t])) `liftM` beta

107+patternGen (as,cs,ts) (PVar v) = do

108+ b <- beta

109+ let cs' = map (\x -> ctx (Var v) $ VarT x :=: b) $ Map.findWithDefault [] v as

110+ return ( Map.delete v as, Set.union cs $ Set.fromList cs', ts ++ [b] )

111+patternGen (as,cs,ts) p@(PData name ps) = do

112+ constr <- guid

113+ output <- beta

114+ (as',cs',ts') <- foldM patternGen (as,cs,[]) ps

115+ let t = foldr (==>) output ts'

116+ let getC | isTupleString name = do

117+ vs <- mapM (\_ -> beta) ps

118+ return . Set.singleton . ctx p $ output :=: ADT name vs

119+ | otherwise = return Set.empty

120+ cs'' <- getC

121+ return ( unionA as' (Map.singleton name [constr])

122+ , Set.unions [cs',cs'', Set.singleton . ctx p $ VarT constr :=: t]

123+ , ts ++ [output] )

124+

125+

126+defScheme :: Definition -> GuidCounter (Map.Map String [X], Scheme)

127+defScheme (Definition name args e) = do

128+ (as,cs,hint) <- defGen name args e

129+ return ( as, snd hint )

130+

131+defGen name args e = do

121132 argDict <- mapM (\a -> liftM ((,) a) guid) args

122133 (as,cs,t) <- gen e

123134 let genCs (arg,x) = do

124135 v <- guid

125− return . map (\y -> VarT x :=: VarT y) $ Map.findWithDefault [v] arg as

136+ return . map (\y -> Context arg $ VarT x :=: VarT y) $ Map.findWithDefault [v] arg as

126137 cs' <- concat `liftM` mapM genCs argDict

127− let cs'' = map (\(Context _ c) -> c) (Set.toList cs)

138+ let as' = foldr Map.delete as args

128139 let tipe = foldr (==>) t $ map (VarT . snd) argDict

129− return ( foldr Map.delete as args

130− , Set.empty

131− , [ (name, Forall (map snd argDict) (cs' ++ cs'') tipe) ] )

140+ scheme <- generalize (concat $ Map.elems as') $

141+ Forall (map snd argDict) (cs' ++ Set.toList cs) tipe

142+ return ( as', Set.empty, (name, scheme) )

143+

144+stmtGen (Def name args e) = do (as,cs,hint) <- defGen name args e

145+ return ( as, cs, [hint] )

132146

133147stmtGen (Datatype name xs tcs) = do schemes <- mapM gen' tcs'

134148 return (Map.empty, Set.empty, schemes)

135149 where names = map (+ (length xs)) [1..5]

136150 tcs' = map (second . map $ rnm names) tcs

137− supers t = zipWith (:<:) (map VarT names)

151+ supers t = map (Context name) $ zipWith (:<:) (map VarT names)

138152 [ number, time, appendable t, comparable, transformable ]

139− gen' (n,ts) = do

140− t <- beta

141− return . (,) n . Forall (xs ++ names) (supers t) $

142− foldr (==>) (ADT name $ map VarT xs) ts

153+ gen' (n,ts) = do t <- beta

154+ let s = Forall (xs ++ names) (supers t) $

155+ foldr (==>) (ADT name $ map VarT xs) ts

156+ (,) n `liftM` generalize [] s

143157 rnm [a,b,c,d,e] (ADT n []) | n == "Number" = VarT a

144158 | n == "Time" = VarT b

145159 | n == "Appendable" = VarT c

@@ -156,12 +170,10 @@ stmtGen (ExportEvent js elm tipe) = do

156170stmtGen (ImportEvent js base elm tipe) = do

157171 (as,cs,t) <- gen base

158172 return ( as

159− , Set.insert (ctx (Var elm) (t :=: tipe)) cs

173+ , Set.insert (ctx base (signalOf t :=: tipe)) cs

160174 , [ (elm, Forall [] [] tipe) ] )

161175

162−ffiHints (ims,exs) =

163− map (\(_,_,n,t) -> n -: t) ims ++ map (\(_,n,t) -> n -: t) exs

176+getDatatypeInfo (Datatype name args tcs) =

177+ Just (name, args, tcs)

178+getDatatypeInfo _ = Nothing

164179

165−checkFFI dict ims exs = list $ ims' ++ exs'

166− where ims' = map (\(_,b,n,_)-> Binop "==" (Var n) (App (Var "constant") b)) ims

167− exs' = map (\(_,n,_) -> Binop "==" (Var n) (Var $ dict n)) exs

elm/src/Types/Hints.hs+22−18

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

2−module Hints (hints) where

2+module Types.Hints (hints) where

44import Control.Monad (liftM,mapM)

55import Control.Arrow (first)

66import Types

7−import Guid

7+import Types.Substitutions (rescheme)

1010-------- Text and Elements --------

@@ -28,8 +28,11 @@ elements = let iee = int ==> element ==> element in

2828 , "height" -: iee

2929 , "size" -: int ==> iee

3030 , "box" -: iee

31+ , "rightedText" -: text ==> element

3132 , "centeredText" -: text ==> element

3233 , "justifiedText" -: text ==> element

34+ , "asText" -:: a ==> element

35+ , "show" -:: a ==> text

3336 , "collage" -: int ==> int ==> listOf form ==> element

3437 ]

3538

@@ -143,9 +146,13 @@ concreteSignals =

143146-------- Math and Binops --------

144147

145148binop t = t ==> t ==> t

146−scheme1 super t name = (name, Forall [0] [VarT 0 :<: super] (t (VarT 0)))

149+scheme1 super t name =

150+ (name, Forall [0] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: super

151+ ] (t (VarT 0)))

147152scheme2 s1 s2 t name =

148− (name, Forall [0,1] [VarT 0 :<: s1, VarT 1 :<: s2] (t (VarT 0) (VarT 1)))

153+ (name, Forall [0,1] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: s1

154+ , Context ("`" ++ name ++ "'") $ VarT 1 :<: s2

155+ ] (t (VarT 0) (VarT 1)))

149156numScheme t name = scheme1 number t name

150157timeScheme name t = scheme1 time t name

151158twoNums f name = scheme2 number number f name

@@ -166,19 +173,16 @@ bools =

166173 hasType (binop bool) ["&&","||"] ++

167174 map (scheme1 comparable (\t -> t ==> t ==> bool)) ["<",">","<=",">="] ++

168175 [ ( "compare"

169− , Forall [0,1] [ VarT 0 :<: comparable ] (VarT 0 ==> VarT 0 ==> VarT 1) )

176+ , Forall [0,1] [ Context "`compare'" $ VarT 0 :<: comparable ] (VarT 0 ==> VarT 0 ==> VarT 1) )

170177 ]

171178

172179-------- Polymorphic Functions --------

173180

174−var = VarT `liftM` guid

175−vars n = mapM (const var) [1..n]

181+[a,b,c] = map VarT [1,2,3]

176182

177183infix 8 -::

178184name -:: tipe = (name, Forall [1,2,3] [] tipe)

179185

180−[a,b,c] = map VarT [1,2,3]

181−

182186funcs =

183187 [ "id" -:: a ==> a

184188 , "==" -:: a ==> a ==> bool

@@ -187,7 +191,7 @@ funcs =

187191 , "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)

188192 , "$" -:: (a ==> b) ==> a ==> b

189193 , ":" -:: a ==> listOf a ==> listOf a

190− , (,) "++" . Forall [0,1] [ VarT 0 :<: appendable (VarT 1) ] $ VarT 0 ==> VarT 0 ==> VarT 0

194+ , (,) "++" . Forall [0,1] [ Context "`++'" $ VarT 0 :<: appendable (VarT 1) ] $ VarT 0 ==> VarT 0 ==> VarT 0

191195 , "Cons" -:: a ==> listOf a ==> listOf a

192196 , "Nil" -:: listOf a

193197 , "Just" -:: a ==> maybeOf a

@@ -218,11 +222,11 @@ lists =

218222 , "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b

219223 , "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b

220224 , "scanl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> listOf b

221− , (,) "concat" . Forall [0,1] [ VarT 0 :<: appendable (VarT 1) ] $

225+ , (,) "concat" . Forall [0,1] [ Context "`concat'" $ VarT 0 :<: appendable (VarT 1) ] $

222226 listOf (VarT 0) ==> VarT 0

223− , (,) "concatMap" . Forall [0,1,2] [ VarT 0 :<: appendable (VarT 1) ] $

227+ , (,) "concatMap" . Forall [0,1,2] [ Context "`concatMap'" $ VarT 0 :<: appendable (VarT 1) ] $

224228 (VarT 2 ==> VarT 0) ==> listOf (VarT 2) ==> VarT 0

225− , (,) "intercalate" . Forall [0,1] [ VarT 0 :<: appendable (VarT 1) ] $

229+ , (,) "intercalate" . Forall [0,1] [ Context "`intercalate'" $ VarT 0 :<: appendable (VarT 1) ] $

226230 VarT 0 ==> listOf (VarT 0) ==> VarT 0

227231 , "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c

228232 ] ++ map (numScheme (\n -> listOf n ==> n)) [ "sum", "product"

@@ -231,8 +235,8 @@ lists =

231235

232236-------- Everything --------

233237

234−hints =

235− concat [ funcs, lists, signals, math, bools, str2elem, textAttrs

236− , elements, directions, colors, lineTypes, shapes

237− , concreteSignals, casts, polyCasts, json

238− ]

238+hints = mapM (\(n,s) -> (,) n `liftM` rescheme s) hs

239+ where hs = concat [ funcs, lists, signals, math, bools, str2elem, textAttrs

240+ , elements, directions, colors, lineTypes, shapes

241+ , concreteSignals, casts, polyCasts, json

242+ ]

elm/src/Types/Substitutions.hsnew file+98

@@ -0,0 +1,98 @@

2+module Types.Substitutions (cSub

3+ ,tSub

4+ ,cSubNoContext

5+ ,cFreeVars

6+ ,schemeSub

7+ ,concretize

8+ ,rescheme

9+ ,generalize) where

10+

11+import Control.DeepSeq (NFData (..), deepseq)

12+import Control.Monad (liftM)

13+import Data.List (foldl')

14+import qualified Data.Set as Set

15+import Guid

16+import Types

17+

18+force x = x `deepseq` x

19+

20+instance (NFData a) => NFData (Context c a) where

21+ rnf (Context _ a) = a `deepseq` ()

22+

23+instance NFData Constraint where

24+ rnf (t1 :=: t2) = t1 `deepseq` t2 `deepseq` ()

25+ rnf (t :<: _) = t `deepseq` ()

26+ rnf (t :<<: _) = t `deepseq` ()

27+

28+instance NFData Type where

29+ rnf (LambdaT t1 t2) = t1 `deepseq` t2 `deepseq` ()

30+ rnf (ADT _ ts) = foldl' (\acc x -> x `deepseq` acc) () ts

31+ rnf t = t `seq` ()

32+

33+tSub k v t@(VarT x) = if k == x then v else t

34+tSub k v (LambdaT t1 t2) = force $ LambdaT (tSub k v t1) (tSub k v t2)

35+tSub k v (ADT name ts) = ADT name (map (force . tSub k v) ts)

36+tSub k v (Super ts) = Super ts

37+

38+schemeSubHelp k s c t1 t2 relation = do

39+ (t1',cs1) <- f1 ; (t2',cs2) <- f2

40+ return (Context c (relation t1' t2') : cs1 ++ cs2)

41+ where f1 | hasVar k t1 = do (v, cs) <- concretize s; return (tSub k v t1, cs)

42+ | otherwise = return (t1, [])

43+ f2 | hasVar k t2 = do (v, cs) <- concretize s; return (tSub k v t2, cs)

44+ | otherwise = return (t2, [])

45+

46+schemeSub k s (Context ctx (t1 :=: t2)) = schemeSubHelp k s ctx t1 t2 (:=:)

47+schemeSub k s (Context ctx (t1 :<: t2)) = schemeSubHelp k s ctx t1 t2 (:<:)

48+schemeSub k s (Context ctx c@(x :<<: Forall cxs ccs ctipe))

49+ | k `elem` cxs || k `notElem` cFreeVars c = return [Context ctx c]

50+ | otherwise = do

51+ Forall xs cs tipe <- rescheme s

52+ let constraints = (map (cSub k tipe) $ cs ++ ccs)

53+ let c' = x :<<: Forall (cxs ++ xs) constraints (tSub k tipe ctipe)

54+ return [ Context ctx c' ]

55+

56+hasVar v (VarT x) = v == x

57+hasVar v (LambdaT t1 t2) = hasVar v t1 || hasVar v t2

58+hasVar v (ADT _ ts) = any (hasVar v) ts

59+hasVar v (Super _ ) = False

60+

61+cSub k v (Context ctx c) = Context ctx (cSubNoContext k v c)

62+

63+cSubNoContext k v (t1 :=: t2) = force $ tSub k v t1 :=: tSub k v t2

64+cSubNoContext k v (t :<: super) = force $ tSub k v t :<: super

65+cSubNoContext k v (x :<<: poly@(Forall vs cs tipe)) = force $ x :<<: poly'

66+ where poly' | k `elem` vs = poly

67+ | otherwise = let cs' = map (cSub k v) cs in

68+ Forall vs cs' (tSub k v tipe)

69+

70+concretize (Forall xs cs t) = do

71+ pairs <- mapM (\x -> liftM ((,) x) guid) xs

72+ return ( foldl' (\t' (k,v) -> tSub k (VarT v) t) t pairs

73+ , foldl' (\cs' (k,v) -> map (cSub k $ VarT v) cs') cs pairs )

74+

75+rescheme :: Scheme -> GuidCounter Scheme

76+rescheme (Forall xs cs t) = do

77+ pairs <- mapM (\x -> liftM ((,) x) guid) xs

78+ let t' = foldl' (\t' (k,v) -> tSub k (VarT v) t') t pairs

79+ let cs' = foldl' (\cs' (k,v) -> map (cSub k $ VarT v) cs') cs pairs

80+ return $ Forall (map snd pairs) cs' t'

81+

82+freeVars (VarT v) = [v]

83+freeVars (LambdaT t1 t2) = freeVars t1 ++ freeVars t2

84+freeVars (ADT _ ts) = concatMap freeVars ts

85+freeVars (Super _ ) = []

86+

87+cFreeVars (t1 :=: t2) = freeVars t1 ++ freeVars t2

88+cFreeVars (t1 :<: t2) = freeVars t1 ++ freeVars t2

89+cFreeVars (x :<<: Forall xs cs t) = filter (`notElem` xs) frees

90+ where frees = concatMap (\(Context _ c) -> cFreeVars c) cs ++ freeVars t

91+

92+decontext (Context _ c) = c

93+

94+generalize :: [X] -> Scheme -> GuidCounter Scheme

95+generalize exceptions (Forall xs cs t) = rescheme (Forall (xs ++ frees) cs t)

96+ where allFrees = Set.fromList $ freeVars t ++ concatMap (cFreeVars . decontext) cs

97+ frees = Set.toList $ Set.difference allFrees (Set.fromList exceptions)

98+

elm/src/Types/Types.hs+22−13

@@ -10,23 +10,31 @@ type X = Int

1010data Type = LambdaT Type Type

1111 | VarT X

1212 | ADT String [Type]

13+ | Super (Set.Set Type)

1314 deriving (Eq, Ord)

1415

15−data Scheme = Forall [X] [Constraint] Type deriving (Eq, Ord, Show)

16−

17−data SuperType = SuperType String (Set.Set Type) deriving (Eq, Ord)

16+data Scheme = Forall [X] [Context String Constraint] Type deriving (Eq, Ord)

1817

1918data Constraint = Type :=: Type

20− | Type :<: SuperType

21− | Type :<<: Scheme

19+ | Type :<: Type

20+ | X :<<: Scheme

2221 deriving (Eq, Ord, Show)

2322

23+data Context c v = Context c v deriving (Eq, Show)

24+

25+ctx c = Context ("`" ++ show c ++ "'")

26+extendCtx ctx2 (Context ctx1 c) = Context (ctx1 ++ " in " ++ ctx2) c

27+

28+instance (Ord a, Eq c) => Ord (Context c a) where

29+ compare (Context _ x) (Context _ y) = compare x y

30+

31+

2432tipe t = ADT t []

2533

2634

2735int = tipe "Int"

2836float = tipe "Float"

29−number = SuperType "Number" (Set.fromList [ int, float ])

37+number = Super (Set.fromList [ int, float ])

3038

3139char = tipe "Char"

3240bool = tipe "Bool"

@@ -34,7 +42,7 @@ bool = tipe "Bool"

3442string = listOf char -- tipe "String"

3543text = tipe "Text"

3644

37−time = SuperType "Time" (Set.fromList [ int, float, tipe "Number" ])

45+time = Super (Set.fromList [ int, float ])

3846

3947element = tipe "Element"

4048direction = tipe "Direction"

@@ -49,9 +57,9 @@ tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts

4957maybeOf t = ADT "Maybe" [t]

5058pairOf t = tupleOf [t,t]

5159point = pairOf int

52−appendable t = SuperType "Appendable" (Set.fromList [ string, text, listOf t ])

53−comparable = SuperType "Comparable" (Set.fromList [ int, float, char, string, tipe "Number", tipe "Time" ])

54−transformable = SuperType "Transformable" (Set.fromList [ shape, line ])

60+appendable t = Super (Set.fromList [ string, text, listOf t ])

61+comparable = Super (Set.fromList [ int, float, char, string ])

62+transformable = Super (Set.fromList [ shape, line ])

5563

5664jsBool = tipe "JSBool"

5765jsNumber = tipe "JSNumber"

@@ -85,10 +93,11 @@ instance Show Type where

8593 then parens . intercalate "," $ map show cs

8694 else case cs of [] -> name

8795 _ -> parens $ name ++ " " ++ unwords (map show cs)

96+ ; Super ts -> "{" ++ (intercalate "," . map show $ Set.toList ts) ++ "}"

8897 }

8998

90−instance Show SuperType where

91− show (SuperType n ts) = "" ++ n ++ " (a type in {" ++ subs ++ "})"

92− where subs = intercalate "," . map show $ Set.toList ts

99+instance Show Scheme where

100+ show (Forall xs cs t) = "Forall " ++ show xs ++ cs' ++ "\n " ++ show t

101+ where cs' = concatMap (concatMap ("\n "++) . lines . show) cs

93102

94103isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)

elm/src/Types/Unify.hs+68−56

@@ -1,23 +1,28 @@

2−module Unify (unify) where

2+module Types.Unify (unify) where

4−import Constrain

54import Control.Arrow (second)

65import Control.Monad (liftM)

76import Data.List (foldl')

87import qualified Data.Set as Set

8+import qualified Data.Map as Map

99import Guid

1010import Types

11+import Types.Constrain

12+import Types.Substitutions

1113

12−import Control.DeepSeq (NFData (..), deepseq)

14+--import System.IO.Unsafe

15+

16+prints xs v = v --unsafePerformIO (putStrLn "----------" >> mapM print xs) `seq` v

17+prints' xs v = v --prints (Map.toList xs) v

1318

1419unify hints modul = run $ do

1520 cs <- constrain hints modul

16− solver cs []

21+ prints cs $ solver cs Map.empty

1722

1823eq ctx t1 t2 = Context ctx (t1 :=: t2)

1924

20−solver [] subs = return $ Right subs

25+solver [] subs = prints (Map.toList subs) $ return $ Right subs

2126

2227-------- Destruct Type-constructors --------

2328

@@ -29,70 +34,77 @@ solver ((Context ctx (LambdaT t1 t2 :=: LambdaT t1' t2')) : cs) subs =

2934

3035-------- Type-equality --------

3136

32−solver ((Context ctx (VarT x :=: t)) : cs) subs =

33− solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs

34−solver ((Context ctx (t :=: VarT x)) : cs) subs = solver ((Context ctx (VarT x :=: t)) : cs) subs

37+solver (Context ctx (VarT x :=: VarT y) : cs) subs

38+ | x == y = solver cs subs

39+ | otherwise =

40+ case (Map.lookup x subs, Map.lookup y subs) of

41+ (Just (Super xts), Just (Super yts)) ->

42+ let ts = Set.intersection xts yts

43+ setXY t = Map.insert x t . Map.insert y t

44+ in case Set.toList ts of

45+ [] -> unionError ctx xts yts

46+ [t] -> solver (map (cSub x t . cSub y t) cs) $ setXY t subs

47+ _ -> solver cs $ setXY (Super ts) subs

48+ (Just (Super xts), _) ->

49+ solver (map (cSub y (VarT x)) cs) $ Map.insert y (VarT x) subs

50+ (_, _) ->

51+ solver (map (cSub x (VarT y)) cs) $ Map.insert x (VarT y) subs

52+solver (Context ctx (VarT x :=: t) : cs) subs =

53+ case Map.lookup x subs of

54+ Nothing -> solver (map (cSub x t) cs) . Map.map (tSub x t) $ Map.insert x t subs

55+ Just (Super ts) ->

56+ let ts' = Set.intersection ts (Set.singleton t) in

57+ case Set.toList ts' of

58+ [] -> solver (Context ctx (t :<: Super ts) : cs) subs

59+ [t'] -> solver (map (cSub x t') cs) $ Map.insert x t' subs

60+ _ -> solver cs $ Map.insert x (Super ts') subs

61+ Just t' -> solver (Context ctx (t' :=: t) : cs) subs

62+solver ((Context ctx (t :=: VarT x)) : cs) subs =

63+ solver ((Context ctx (VarT x :=: t)) : cs) subs

3564solver ((Context ctx (t1 :=: t2)) : cs) subs

3665 | t1 == t2 = solver cs subs

3766 | otherwise = uniError ctx t1 t2

3867

68+

3969-------- subtypes --------

4070

41−solver (c@(Context ctx (VarT x :<: SuperType n ts)) : cs) subs

42− | all isSuper cs = solver ((Context ctx (VarT x :=: ADT n [])) : cs) subs

43− | otherwise = solver (cs ++ [c]) subs

44− where isSuper (Context _ (VarT _ :<: _)) = True

45− isSuper _ = False

46−solver ((Context ctx (t@(ADT n1 []) :<: st@(SuperType n2 ts))) : cs) subs

47− | n1 == n2 || Set.member t ts = solver cs subs

48− | otherwise = return . Left $ "Type error: " ++ show t ++

49− " is not a " ++ show st ++

50− " in context " ++ show ctx

51−solver ((Context ctx (t@(ADT "List" [_]) :<: st@(SuperType n' ts'))) : cs) subs

52− | any f (Set.toList ts') || Set.member t ts' = solver cs subs

53− | otherwise = return . Left $ "Type error: " ++ show t ++

54− " is not a " ++ show st ++

55− " in context " ++ show ctx

71+solver (Context ctx (VarT x :<: Super ts) : cs) subs =

72+ case Map.lookup x subs of

73+ Nothing -> solver cs $ Map.insert x (Super ts) subs

74+ Just (Super ts') ->

75+ case Set.toList $ Set.intersection ts ts' of

76+ [] -> unionError ctx ts ts'

77+ [t] -> solver (map (cSub x t) cs) $ Map.insert x t subs

78+ ts'' -> solver cs $ Map.insert x (Super $ Set.fromList ts'') subs

79+

80+solver (Context ctx (ADT "List" [t] :<: Super ts) : cs) subs

81+ | any f (Set.toList ts) = solver cs subs

82+ | otherwise = subtypeError ("aoeu" ++ ctx) (ADT "List" [t]) (Super ts)

5683 where f (ADT "List" [VarT _]) = True

84+ f (ADT "List" [t']) = t == t'

5785 f _ = False

5886

59−solver ((Context ctx (t :<: st@(SuperType n ts))) : cs) subs

87+solver (Context ctx (t :<: Super ts) : cs) subs

6088 | Set.member t ts = solver cs subs

61− | otherwise = return . Left $ "Type error: " ++ show t ++

62− " is not a " ++ show st

63−

64−solver ((Context ctx (t1 :<<: Forall xs cs' t2)) : cs) subs = do

65− pairs <- mapM (\x -> liftM ((,) x . VarT) guid) xs

66− let t2' = foldr (uncurry tSub) t2 pairs

67− let cs'' = foldr (\(k,v) -> map (cSub k v)) (map (Context ctx) cs') pairs

68− let constrs = ((Context ctx (t1 :=: t2')) : cs'' ++ cs)

69− solver constrs subs

70−

89+ | otherwise = subtypeError ("htns" ++ ctx) t (Super ts)

7190

72−cSub k v (Context c (t1 :=: t2) ) = force . Context c $ tSub k v t1 :=: tSub k v t2

73−cSub k v (Context c (t :<: super)) = force . Context c $ tSub k v t :<: super

74−cSub k v (Context c (t :<<: poly)) = force . Context c $ tSub k v t :<<: poly

91+solver (Context ctx (x :<<: s) : cs) subs

92+ | any (\(Context _ c) -> x `elem` cFreeVars c) cs =

93+ do cs' <- concat `liftM` mapM (schemeSub x s) cs

94+ solver cs' subs

95+ | otherwise =

96+ do (t,cs') <- concretize s

97+ solver (Context ctx (VarT x :=: t) : map (extendCtx ctx) cs' ++ cs) subs

7598

76−tSub k v t@(VarT x) = if k == x then v else t

77−tSub k v (LambdaT t1 t2) = force $ LambdaT (tSub k v t1) (tSub k v t2)

78−tSub k v (ADT name ts) = ADT name (map (force . tSub k v) ts)

7999

80100uniError ctx t1 t2 =

81101 return . Left $ "Type error: " ++ show t1 ++

82102 " is not equal to " ++ show t2 ++

83− " in context " ++ show ctx

84−

85−force x = x `deepseq` x

86−

87−instance (NFData a) => NFData (Context c a) where

88− rnf (Context _ a) = a `deepseq` ()

89−

90−instance NFData Constraint where

91− rnf (t1 :=: t2) = t1 `deepseq` t2 `deepseq` ()

92− rnf (t :<: _) = t `deepseq` ()

93− rnf (t :<<: _) = t `deepseq` ()

94−

95−instance NFData Type where

96− rnf (LambdaT t1 t2) = t1 `deepseq` t2 `deepseq` ()

97− rnf (ADT _ ts) = foldl' (\acc x -> x `deepseq` acc) () ts

98− rnf t = t `seq` ()

103+ " in context " ++ ctx

104+unionError ctx ts ts' =

105+ return . Left $ concat [ "Type error: There are no types in both "

106+ , show (Super ts), " and ", show (Super ts')

107+ , " in context ", ctx ]

108+subtypeError ctx t s =

109+ return . Left $ concat [ "Type error: ", show t, " is not a ", show s

110+ , " in context ", ctx ]