9e90c58 · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

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

9e90c58evancz14 years ago

elm/Elm.cabal+8−8

compare with master

unifiedsplit

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

50 ParseModules,

51 ParseForeign,

52 Types,

53− Constrain,

53+ Types.Constrain,

54− Hints,

54+ Types.Hints,

55− Types,

55+ Types.Substitutions,

56− Unify

56+ Types.Unify

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

59 containers >= 0.3,

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

87 ParseModules,

88 ParseForeign,

89 Types,

90− Constrain,

90+ Types.Constrain,

91− Hints,

91+ Types.Hints,

92− Types,

92+ Types.Substitutions,

93− Unify

93+ Types.Unify

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

96 containers >= 0.3,

elm/src/Ast.hs+2−1

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

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

46 | ImportEvent String Expr String Type

47 | ExportEvent String String Type

48− deriving (Eq)

48+ deriving (Eq,Show)

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

51nil = Data "Nil" []

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

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

101 show (Input i) = i

102

103+

103instance Show Definition where

104instance Show Definition where

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

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

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

106 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)

10import Data.Maybe (mapMaybe)

12import Initialize

13+import Rename (derename)

14showErr :: String -> String

15showErr :: String -> String

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

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

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

56 export = getExports exps stmts

57 export = getExports exps stmts

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

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

59−stripID var

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

61− | otherwise = var

62−

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

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

64 where pairs = mapMaybe pair $ concatMap get stmts

61 where pairs = mapMaybe pair $ concatMap get stmts

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

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

66− where y = stripID x

63+ where y = derename x

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

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

68 Datatype _ _ tcs -> map fst tcs

65 Datatype _ _ tcs -> map fst tcs

69 ImportEvent _ _ x _ -> [x]

66 ImportEvent _ _ x _ -> [x]

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

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

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

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

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

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

101stmtToJS (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)

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

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

107stmtToJS (ImportEvent js base elm _) =

104stmtToJS (ImportEvent js base elm _) =

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

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

elm/src/Initialize.hs+5−5

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

7import Ast

8import Parser (parseProgram)

9−import Hints (hints)

10−import Unify

11import Rename

9import Rename

12import Types ((-:))

10import Types ((-:))

11+import Types.Hints (hints)

12+import Types.Unify

13import Optimize

16initialize str =

17 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

19 subs <- unify hints modul

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

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

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

22 | 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 =

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

33simp_if a b c = If a b c

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

35+simp_binop = binop

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

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

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

42 where f a b = case op of

38 where f a b = case op of

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

82binop ":" h t = cons h t

81binop ":" h t = cons h t

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

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

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

90binop "$" e1 e2 = App e1 e2

89binop "$" e1 e2 = App e1 e2

92−binop op e1 e2 = Binop op e1 e2

91+binop op e1 e2

93−--}

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 @@

1{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−module Rename (rename) where

2+module Rename (rename, derename) where

4import Ast

5import Control.Arrow (first)

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

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

8−import Data.Char (isLower)

8+import Data.Char (isLower,isDigit)

9import Guid

11+derename var

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

13+ | otherwise = var

14+

11rename :: Module -> Module

15rename :: Module -> Module

12rename (Module name ex im stmts) =

16rename (Module name ex im stmts) =

13 Module name ex im . run $ renameStatements id stmts

17 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

4import Ast

5import Types

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

7import qualified Data.Set as Set

8import qualified Data.Map as Map

9import Control.Arrow (second)

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

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

11import Control.Monad.State (evalState)

12import Guid

13+import Types.Substitutions

14+

15+--import System.IO.Unsafe

16+

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

14beta = VarT `liftM` guid

19beta = VarT `liftM` guid

15unionA = Map.unionWith (++)

20unionA = Map.unionWith (++)

16unionsA = Map.unionsWith (++)

21unionsA = Map.unionsWith (++)

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−

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

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

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

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

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

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)

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

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

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

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

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

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

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)

33gen (Var x) =

34gen (Var x) =

34 do b <- guid

35 do b <- guid

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

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

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

57 let genCs name s = do

58 let genCs name s = do

58 v <- guid

59 v <- guid

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

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

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

60 cs' <- zipWithM genCs names schemes

62 cs' <- zipWithM genCs names schemes

61 return ( foldr Map.delete assumptions names

63 return ( foldr Map.delete assumptions names

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

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

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

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

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

98caseGen tipe (p,e) = do

100caseGen tipe (p,e) = do

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

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

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

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

101− , cs

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

102− , t)

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

103−

105+

104−namesIn PAnything = []

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

105−namesIn (PVar v) = [v]

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

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

108+ b <- beta

107−

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

108−defScheme (Definition name args e) =

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

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

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

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

112+ constr <- guid

111− let genCs (arg,x) = do

113+ output <- beta

112− v <- guid

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

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

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

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

116+ let getC | isTupleString name = do

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

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

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

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

117− return ( foldr Map.delete as args

119+ | otherwise = return Set.empty

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

120+ cs'' <- getC

119−

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+

120−stmtGen (Def name args e) = do

131+defGen name args e = do

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

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

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

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

123 let genCs (arg,x) = do

134 let genCs (arg,x) = do

124 v <- guid

135 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

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

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

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

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

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

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

129− return ( foldr Map.delete as args

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

130− , Set.empty

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

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] )

132

146

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

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

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

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

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

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

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

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

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

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

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

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

139− gen' (n,ts) = do

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

140− t <- beta

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

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

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

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

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

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

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

144 | n == "Time" = VarT b

158 | n == "Time" = VarT b

145 | n == "Appendable" = VarT c

159 | n == "Appendable" = VarT c

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

156stmtGen (ImportEvent js base elm tipe) = do

170stmtGen (ImportEvent js base elm tipe) = do

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

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

158 return ( as

172 return ( as

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

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

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

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

161

175

162−ffiHints (ims,exs) =

176+getDatatypeInfo (Datatype name args tcs) =

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

177+ Just (name, args, tcs)

178+getDatatypeInfo _ = Nothing

164

179

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

4import Control.Monad (liftM,mapM)

5import Control.Arrow (first)

6import Types

7−import Guid

7+import Types.Substitutions (rescheme)

10-------- Text and Elements --------

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

28 , "height" -: iee

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

30 , "box" -: iee

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

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

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

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

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

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

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

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

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

34 ]

37 ]

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

143-------- Math and Binops --------

146-------- Math and Binops --------

144

147

145binop t = t ==> t ==> t

148binop 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)))

147scheme2 s1 s2 t name =

152scheme2 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)))

149numScheme t name = scheme1 number t name

156numScheme t name = scheme1 number t name

150timeScheme name t = scheme1 time t name

157timeScheme name t = scheme1 time t name

151twoNums f name = scheme2 number number f name

158twoNums f name = scheme2 number number f name

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

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

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

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

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

168 [ ( "compare"

175 [ ( "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) )

170 ]

177 ]

171

178

172-------- Polymorphic Functions --------

179-------- Polymorphic Functions --------

173

180

174−var = VarT `liftM` guid

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

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

176

182

177infix 8 -::

183infix 8 -::

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

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

179

185

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

181−

182funcs =

186funcs =

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

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

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

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

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

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

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

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

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

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

193 , ":" -:: 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

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

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

192 , "Nil" -:: listOf a

196 , "Nil" -:: listOf a

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

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

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

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

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

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

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

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

224 , "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) ] $

222 listOf (VarT 0) ==> VarT 0

226 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) ] $

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

228 (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) ] $

226 VarT 0 ==> listOf (VarT 0) ==> VarT 0

230 VarT 0 ==> listOf (VarT 0) ==> VarT 0

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

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

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

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

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

231

235

232-------- Everything --------

236-------- Everything --------

233

237

234−hints =

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

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

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

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

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

237− , concreteSignals, casts, polyCasts, json

241+ , concreteSignals, casts, polyCasts, json

238− ]

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

10data Type = LambdaT Type Type

11 | VarT X

12 | ADT String [Type]

13+ | Super (Set.Set Type)

13 deriving (Eq, Ord)

14 deriving (Eq, Ord)

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

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

16−

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

19data Constraint = Type :=: Type

18data Constraint = Type :=: Type

20− | Type :<: SuperType

19+ | Type :<: Type

21− | Type :<<: Scheme

20+ | X :<<: Scheme

22 deriving (Eq, Ord, Show)

21 deriving (Eq, Ord, Show)

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+

24tipe t = ADT t []

32tipe t = ADT t []

27int = tipe "Int"

35int = tipe "Int"

28float = tipe "Float"

36float = tipe "Float"

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

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

31char = tipe "Char"

39char = tipe "Char"

32bool = tipe "Bool"

40bool = tipe "Bool"

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

34string = listOf char -- tipe "String"

42string = listOf char -- tipe "String"

35text = tipe "Text"

43text = tipe "Text"

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

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

39element = tipe "Element"

47element = tipe "Element"

40direction = tipe "Direction"

48direction = tipe "Direction"

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

49maybeOf t = ADT "Maybe" [t]

57maybeOf t = ADT "Maybe" [t]

50pairOf t = tupleOf [t,t]

58pairOf t = tupleOf [t,t]

51point = pairOf int

59point = pairOf int

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

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

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

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

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

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

56jsBool = tipe "JSBool"

64jsBool = tipe "JSBool"

57jsNumber = tipe "JSNumber"

65jsNumber = tipe "JSNumber"

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

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

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

86 else case cs of [] -> name

94 else case cs of [] -> name

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

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

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

88 }

97 }

90−instance Show SuperType where

99+instance Show Scheme where

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

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

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

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

102

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

103isTupleString 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

5import Control.Arrow (second)

4import Control.Arrow (second)

6import Control.Monad (liftM)

5import Control.Monad (liftM)

7import Data.List (foldl')

6import Data.List (foldl')

8import qualified Data.Set as Set

7import qualified Data.Set as Set

8+import qualified Data.Map as Map

9import Guid

10import Types

11+import Types.Constrain

12+import Types.Substitutions

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

14unify hints modul = run $ do

19unify hints modul = run $ do

15 cs <- constrain hints modul

20 cs <- constrain hints modul

16− solver cs []

21+ prints cs $ solver cs Map.empty

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

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

20−solver [] subs = return $ Right subs

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

22-------- Destruct Type-constructors --------

27-------- Destruct Type-constructors --------

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

30-------- Type-equality --------

35-------- Type-equality --------

32−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

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

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

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

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

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

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

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

36 | t1 == t2 = solver cs subs

65 | t1 == t2 = solver cs subs

37 | otherwise = uniError ctx t1 t2

66 | otherwise = uniError ctx t1 t2

68+

39-------- subtypes --------

69-------- subtypes --------

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

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

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

72+ case Map.lookup x subs of

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

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

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

74+ Just (Super ts') ->

45− isSuper _ = False

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

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

76+ [] -> unionError ctx ts ts'

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

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

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

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

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

79+

50− " in context " ++ show ctx

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

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

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

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

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

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

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

55− " in context " ++ show ctx

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

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

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

57 f _ = False

85 f _ = False

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

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

60 | Set.member t ts = solver cs subs

88 | Set.member t ts = solver cs subs

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

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

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−

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

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

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

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

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

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

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)

80uniError ctx t1 t2 =

100uniError ctx t1 t2 =

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

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

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

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

83− " in context " ++ show ctx

103+ " in context " ++ ctx

84−

104+unionError ctx ts ts' =

85−force x = x `deepseq` x

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

86−

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

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

107+ , " in context ", ctx ]

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

108+subtypeError ctx t s =

89−

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

90−instance NFData Constraint where

110+ , " in context ", ctx ]

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` ()