79e465c · elk · git.iko.soy

git.iko.soy/elk

Change representation of let-expressions to fix let-polymorphism. Better type inference for case-expressions (all cases must have same type).

commit79e465c9e06c08bcbc8aaa791a07cfd11934a4ca authorevancz <info@elm-lang.org> dateSun 22 Jul 2012, 00:48 (14 years ago) parente81bdc9

11 files changed+113−77

compare with master

unifiedsplit

elm/src/Ast.hs+5−4 elm/src/Gen/CompileToJS.hs+6−7 elm/src/Gen/ExtractNoscript.hs+3−5 elm/src/Initialize.hs+12−11 elm/src/Optimize.hs+2−1 elm/src/Parse/ParseExpr.hs+7−3 elm/src/Parse/ParseTypes.hs+22−16 elm/src/Parse/Parser.hs+2−5 elm/src/Parse/Patterns.hs+15−12 elm/src/Rename.hs+5−5 elm/src/Types/Constrain.hs+34−8

elm/src/Ast.hs+5−4

@@ -6,15 +6,13 @@ import Data.List (intercalate)

66import Types

77import Guid

9−data Module = Module [String] Exports Imports Defs JSFFI

9+data Module = Module [String] Exports Imports [Definition] JSFFI

1010

1111type Exports = [String]

1212

1313type Imports = [(String, ImportMethod)]

1414data ImportMethod = As String | Hiding [String] | Importing [String]

1515

16−type Defs = [(String,Expr)]

17−

1816type JSFFI = ( [(String, Expr, String, Type)]

1917 , [(String, String, Type)] )

2018

@@ -37,12 +35,15 @@ data Expr = IntNum Int

3735 | Fold Expr Expr Expr

3836 | Async Expr

3937 | Input String

40− | Let [(String,Expr)] Expr

38+ | Let [Definition] Expr

4139 | Var String

4240 | Case Expr [(Pattern,Expr)]

4341 | Data String [Expr]

4442 deriving (Show, Eq)

4543

44+data Definition = Definition String [String] Expr

45+ deriving (Show, Eq)

46+

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

4748nil = Data "Nil" []

4849list = foldr cons nil

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

@@ -54,7 +54,7 @@ jsModule (Module names exports imports defs foreigns) =

5454 body = jsDefs defs

5555 export = ret . braces . intercalate "," $ mapMaybe getNames defs

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

57− getNames (x,_) =

57+ getNames (Definition x _ _) =

5858 let y = reverse . tail . dropWhile isDigit $ reverse x in

5959 if y `elem` exps then Just $ y ++ ":" ++ x else Nothing

6060 (ims,exs) = let (i,e) = foreigns in

@@ -115,12 +115,11 @@ toJS expr =

115115jsLet defs e' = jsFunc "" (jsDefs defs ++ ret (toJS e')) ++ "()"

116116

117117jsDefs defs = concatMap toDef $ sortBy f defs

118− where f a b = compare (isLambda a) (isLambda b)

119− isLambda (_, Lambda _ _) = 1

120− isLambda _ = 0

121− toDef (f, Lambda x e) =

122− "\nfunction " ++ f ++ parens x ++ braces (ret $ toJS e) ++ ";"

123− toDef (x, e) = assign x (toJS e)

118+ where f a b = compare (valueOf a) (valueOf b)

119+ valueOf (Definition _ args _) = min 1 (length args)

120+ toDef (Definition x [] e) = assign x (toJS e)

121+ toDef (Definition f (a:as) e) =

122+ "\nfunction " ++ f ++ parens a ++ braces (ret . toJS $ foldr Lambda e as) ++ ";"

124123

125124jsCase e [c] = jsMatch c ++ parens (toJS e)

126125jsCase e cases = "(function(){" ++

elm/src/Gen/ExtractNoscript.hs+3−5

@@ -4,7 +4,7 @@ module ExtractNoscript (extract) where

44import Ast

66extract (Module _ _ _ defs _) =

7− concatMap (\s -> "<p>" ++ s ++ "</p>") $ concatMap (extract' . snd) defs

7+ concatMap (\s -> "<p>" ++ s ++ "</p>") $ concatMap (\(Definition _ _ e) -> extract' e) defs

99extract' expr =

1010 let f = extract' in

@@ -24,12 +24,10 @@ extract' expr =

2424 App (Var "monospace") e -> tag "code" e

2525 App e1 e2 -> f e1 ++ f e2

2626 If eb et ef -> f et ++ f ef

27− Let defs e -> concatMap (f . snd) defs ++ f e

27+ Let defs e -> concatMap (\(Definition _ _ d) -> f d) defs ++ f e

2828 Var _ -> []

2929 Case e cases -> concatMap (f . snd) cases

3030 Data _ es -> concatMap f es

3131 _ -> []

3232

33−tag t e = case extract' e of

34− [s] -> [ concat [ "<", t, ">", s, "</", t, ">" ] ]

35− ss -> ss

33+tag t e = map (\s -> concat [ "<", t, ">", s, "</", t, ">" ]) (extract' e)

elm/src/Initialize.hs+12−11

@@ -12,17 +12,18 @@ import Types ((-:))

1212import Optimize

1313

1414

15−initialize str = do

16− (Module name ex im defs (ims,exs), tipes) <- parseProgram str

17− let (Let ds _) = rename . Let defs $ Var "_"

18− let dict n = maybe n id . lookup n $ zip (map fst defs) (map fst ds)

19− let allHints = hints ++ tipes ++ ffiHints (ims,exs)

20− subs <- unify allHints . Let ds $ checkFFI dict ims exs

21− let Let defs' _ = optimize (Let ds $ Var "_")

22− let im' = if any ((=="Prelude") . fst) im then im else

23− ("Prelude", Importing []):im

24− let exs' = map (\(js,n,t) -> (js,dict n,t)) exs

25− return (subs `seq` Module name ex im' defs' (ims,exs'))

15+initialize str =

16+ let nameOf (Definition n _ _) = n in

17+ do (Module name ex im defs (ims,exs), tipes) <- parseProgram str

18+ let (Let ds _) = rename . Let defs $ Var "_"

19+ let dict n = maybe n id . lookup n $ zip (map nameOf defs) (map nameOf ds)

20+ let allHints = hints ++ tipes ++ ffiHints (ims,exs)

21+ subs <- unify allHints . Let ds $ checkFFI dict ims exs

22+ let Let defs' _ = optimize (Let ds $ Var "_")

23+ let im' = if any ((=="Prelude") . fst) im then im else

24+ ("Prelude", Importing []):im

25+ let exs' = map (\(js,n,t) -> (js,dict n,t)) exs

26+ return (subs `seq` Module name ex im' defs' (ims,exs'))

2627

2728

2829ffiHints (ims,exs) =

elm/src/Optimize.hs+2−1

@@ -16,7 +16,8 @@ simp expr =

1616 Lambda x e -> Lambda x (f e)

1717 App e1 e2 -> App (f e1) (f e2)

1818 If e1 e2 e3 -> simp_if (f e1) (f e2) (f e3)

19− Let defs e -> Let (map (second f) defs) (f e)

19+ Let defs e -> Let (map simpDef defs) (f e)

20+ where simpDef (Definition func args e) = Definition func args (f e)

2021 Data name es -> Data name (map f es)

2122 Case e cases -> Case (f e) (map (second f) cases)

2223 _ -> expr

elm/src/Parse/ParseExpr.hs+7−3

@@ -80,10 +80,10 @@ ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace

8080

8181lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"

8282 whitespace

83− args <- spaceSep1 patternTerm

83+ pats <- spaceSep1 patternTerm

8484 whitespace ; arrow ; whitespace

8585 e <- expr

86− return $ makeFunction args e

86+ return $ makeLambda pats e

8787

8888letExpr = do

8989 reserved "let"

@@ -118,8 +118,12 @@ assignExpr = do

118118 flattenPatterns patterns exp

119119

120120

121−def = do (fs,es) <- unzip <$> assignExpr

121+def = do ds <- assignExpr

122+ return (ds,[])

123+{--

124+ do (fs,es) <- unzip <$> assignExpr

122125 return (fs, es, map (\_ -> Forall [0] [] (VarT 0)) fs)

126+--}

123127

124128parseDef str =

125129 case parse def "" str of

elm/src/Parse/ParseTypes.hs+22−16

@@ -52,34 +52,40 @@ typeExpr = do

5252typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])

5353typeConstructor = (,) <$> (capVar <?> "another type constructor") <*> spacePrefix (typeSimple <|> typeUnambiguous)

5454

55−datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], [Scheme])

55+datatype :: (Monad m) => ParsecT [Char] u m ([Definition], [(String,Scheme)])

5656datatype = do

5757 reserved "data" <?> "datatype definition (data T = A | B | ...)"

5858 forcedWS ; name <- capVar <?> "name of data-type" ; args <- spacePrefix lowVar

5959 whitespace ; string "=" ; whitespace

6060 tcs <- pipeSep1 typeConstructor

61− return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)

61+ case getConstraints name args tcs of

62+ Right cs -> return (map toDef tcs, cs)

63+ Left msg -> fail msg

6264

6365beta = liftM VarT guid

6466

65−toFunc (name,args) = foldr Lambda (Data name $ map Var argNames) argNames

66− where argNames = map (("a"++) . show) [1..length args]

67+toDef (name,types) = Definition name args (Data name (map Var args))

68+ where args = map (('a':) . show) [1..length types]

6769

68−toTypes name args constructors =

69− map (toType pairs . ADT name $ map (VarT . snd) pairs) constructors

70− where pairs = zip args [1..length args]

70+getConstraints name args constructors =

71+ mapM (toConstraint tvarDict . ADT name $ map (VarT . snd) tvarDict) constructors

72+ where tvarDict = zip args [1..length args]

7173

72−toType pairs outType (name,args) =

73− Forall [1..n+2] cs $ foldr (==>) outType (map toT args)

74− where n = length pairs

74+toConstraint tvarDict outType (name,args) =

75+ ((,) name . Forall [1..n+2] cs . foldr (==>) outType) <$> mapM toT args

76+ where n = length tvarDict

7577 cs = [ VarT (n+1) :<: time, VarT (n+2) :<: number ]

76− toT (LambdaPT t1 t2) = toT t1 ==> toT t2

77− toT (ADTPT name args) = ADT name $ map toT args

78+ toT (LambdaPT t1 t2) = (==>) <$> toT t1 <*> toT t2

79+ toT (ADTPT name args) = ADT name <$> mapM toT args

7880 toT (VarPT x@(c:_))

79− | isLower c = VarT . fromMaybe (-1) $ lookup x pairs

80− | x == "Time" = VarT (n+1)

81− | x == "Number" = VarT (n+2)

82− | otherwise = ADT x []

81+ | isLower c = VarT <$> case lookup x tvarDict of

82+ Just v -> Right v

83+ Nothing -> Left $ msg x

84+ | x == "Time" = return $ VarT (n+1)

85+ | x == "Number" = return $ VarT (n+2)

86+ | otherwise = return $ ADT x []

87+ msg x = "Type variable '" ++ x ++

88+ "' is unbound in type constructor '" ++ name ++ "'."

8389

8490toForeignType (LambdaPT t1 t2) =

8591 fail $ "Elm's JavaScript event interface does not yet handle functions. " ++

elm/src/Parse/Parser.hs+2−5

@@ -21,18 +21,15 @@ freshDef = commitIf (freshLine >> (letter <|> char '_')) $ do

2121defs1 = do d <- datatype <|> def <?> "at least one datatype or variable definition"

2222 (d:) <$> many freshDef

2323

24−defs = do (fss,ess,tss) <- unzip3 <$> defs1

25− return (concat fss, concat ess, concat tss)

26−

2724program = do

2825 optional freshLine

2926 (names,exports) <- option (["Main"],[]) (moduleDef `followedBy` freshLine)

3027 is <- (do try (lookAhead $ reserved "import")

3128 imports `followedBy` freshLine) <|> return []

3229 jsffi <- foreignDefs `followedBy` freshLine <|> return ([],[])

33− (vs,es,ts) <- defs

30+ (defss, schemess) <- unzip <$> defs1

3431 optional freshLine ; optional spaces ; eof

35− return (Module names exports is (zip vs es) jsffi, zip vs ts)

32+ return (Module names exports is (concat defss) jsffi, concat schemess)

3633

3734parseProgram source =

3835 case parse program "" source of

elm/src/Parse/Patterns.hs+15−12

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

1−module Patterns (patternTerm, patternExpr, makeFunction, flattenPatterns) where

1+module Patterns (patternTerm, patternExpr, makeLambda, flattenPatterns) where

33import Ast

44import Data.Char (isUpper)

@@ -29,25 +29,28 @@ patternExpr :: Monad m => ParsecT [Char] u m Pattern

2929patternExpr = foldl1 pcons <$> consSep1 patternTerm <?> "pattern"

3030

3131

32+makeLambda pats body = foldr Lambda (makeBody pats body) (map getName pats)

3233

33−makeFunction args body = foldr func body args

34− where func PAnything e = Lambda "_" e

35− func (PVar x) e = Lambda x e

36− func p e = "t" `Lambda` Case (Var "t") [(p,e)]

34+makeBody pats body = foldr func body pats

35+ where func PAnything e = e

36+ func (PVar x) e = e

37+ func p e = Case (Var $ getName p) [(p,e)]

3738

38−flattenPatterns (PVar f : args) exp = return [(f, makeFunction args exp)]

39+flattenPatterns (PVar f : args) exp =

40+ return [ Definition f (map getName args) (makeBody args exp) ]

3941flattenPatterns [p] exp = return $ matchSingle p exp p

4042flattenPatterns ps _ =

4143 fail $ "Pattern (" ++ unwords (map show ps) ++

4244 ") cannot be used on the left-hand side of an assign statement."

4345

4446matchSingle pat exp p@(PData _ ps) =

45− (v, exp) : concatMap (matchSingle p $ Var v) ps

46− where v = "'" ++ getName p

47−matchSingle pat exp (PVar x) = [ (x, Case exp [(pat,Var x)]) ]

47+ (Definition v [] exp) : concatMap (matchSingle p $ Var v) ps

48+ where v = getName p

49+matchSingle pat exp (PVar x) = [ Definition x [] (Case exp [(pat,Var x)]) ]

4850matchSingle pat exp PAnything = []

4951

50−getName (PData n ps) = n ++ concatMap getName ps

51−getName (PAnything) = "_"

52−getName (PVar x) = x

52+getName p = f p

53+ where f (PData n ps) = n ++ "$" ++ concatMap getName ps

54+ f (PAnything) = "_"

55+ f (PVar x) = x

5356

elm/src/Rename.hs+5−5

@@ -48,11 +48,11 @@ rename' env expr =

4848

4949 Async e -> Async `liftM` rnm e

5050

51− Let defs e -> do

52− let (vs,es) = unzip defs

53− env' <- foldM (\acc x -> snd `liftM` extend acc x) env vs

54− es' <- mapM (rename' env') es; re <- rename' env' e

55− return $ Let (zip (map env' vs) es') re

51+ Let defs e ->

52+ let (fs,argss,es) = unzip3 $ map (\(Definition a b c) -> (a,b,c)) defs in

53+ do env' <- foldM (\acc x -> snd `liftM` extend acc x) env fs

54+ es' <- mapM (rename' env') es; re <- rename' env' e

55+ return $ Let (zipWith3 Definition (map env' fs) argss es') re

5656

5757 Var x -> return . Var $ env x

5858

elm/src/Types/Constrain.hs+34−8

@@ -38,16 +38,23 @@ inference (Lambda x e) =

3838 Map.findWithDefault [] x a

3939 , LambdaT b t )

4040inference (Let defs e) =

41− do (a,c,t) <- inference e

42− let (xs,es) = unzip defs

43− (as,cs,ts) <- unzip3 `liftM` mapM inference es

44− let assumptions = unionsA (a:as)

45− let f x t = map (:=: t) . map VarT $ Map.findWithDefault [] x assumptions

46− let constraints = Set.fromList . concat $ zipWith f xs ts

47− return ( foldr Map.delete assumptions xs

48− , Set.unions $ c:constraints:cs

41+ do (as,cs,t) <- inference e

42+ (ass, schemes) <- liftM unzip (mapM defScheme defs)

43+ let assumptions = unionsA (as:ass)

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

45+ let genCs name s = map (\x -> VarT x :<<: s) $ Map.findWithDefault [] name assumptions

46+ let cs' = Set.fromList . concat $ zipWith genCs names schemes

47+ return ( foldr Map.delete assumptions names

48+ , Set.union cs' cs

4949 , t )

5050

51+inference (Case e cases) =

52+ do (as,cs,t) <- inference e

53+ (ass,css,ts) <- liftM unzip3 $ mapM (caseInference t) cases

54+ return ( unionsA $ as:ass

55+ , Set.unions $ Set.fromList (zipWith (:=:) ts $ tail ts) : cs : css

56+ , head ts)

57+

5158inference (If e1 e2 e3) =

5259 do (a1,c1,t1) <- inference e1

5360 (a2,c2,t2) <- inference e2

@@ -72,3 +79,22 @@ inference other =

7279 _ -> beta >>= primitive

7380

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

82+

83+caseInference tipe (p,e) = do

84+ (as,cs,t) <- inference e

85+ return ( foldr Map.delete as (namesIn p)

86+ , cs

87+ , t)

88+

89+namesIn PAnything = []

90+namesIn (PVar v) = [v]

91+namesIn (PData name ps) = concatMap namesIn ps

92+

93+defScheme (Definition name args e) =

94+ do argDict <- mapM (\a -> liftM ((,) a) guid) args

95+ (as,cs,t) <- inference e

96+ let genCs (arg,x) = map (\y -> VarT x :=: VarT y) $ Map.findWithDefault [] arg as

97+ let cs' = concatMap genCs argDict

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

99+ return (foldr Map.delete as args

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