bccfece · elk · git.iko.soy

README.md+4

compare with master

unifiedsplit

@@ -3,6 +3,10 @@ Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/)

3

4## Install

5

6+**Note for OS X 10.9 Maverics:** you must follow

7+[these directions](http://justtesting.org/post/64947952690/the-glasgow-haskell-compiler-ghc-on-os-x-10-9)

8+before continuing!

9+

6Download the [Haskell Platform 2012.2.0.0 or later](http://hackage.haskell.org/platform/).

10Download the [Haskell Platform 2012.2.0.0 or later](http://hackage.haskell.org/platform/).

7Once the Haskell Platform is installed:

11Once the Haskell Platform is installed:

8

12

compiler/SourceSyntax/PrettyPrint.hs+11

@@ -21,3 +21,14 @@ variable x =

21

22reprime :: String -> String

23reprime = map (\c -> if c == '$' then '\'' else c)

24+

25+eightyCharLines :: Int -> String -> String

26+eightyCharLines indent message = answer

27+ where

28+ (answer,_,_) = foldl step (replicate (indent-1) ' ', indent-1, "") chunks

29+

30+ chunks = map (\w -> (w, length w)) (words message)

31+ spaces = replicate indent ' '

32+ step (sentence, slen, space) (word, wlen)

33+ | slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")

34+ | otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")

compiler/Transform/Check.hs+37−2

@@ -15,7 +15,9 @@ import Text.PrettyPrint as P

15

16mistakes :: (Data t, Data v) => [Declaration t v] -> [Doc]

17mistakes decls =

18+ concat [ infiniteTypeAliases decls

19+ , illFormedTypes decls

18− illFormedTypes decls ++ map P.text (concatMap findErrors (getLets decls))

20+ , map P.text (concatMap findErrors (getLets decls)) ]

19 where

21 where

20 findErrors defs = duplicates defs ++ badOrder defs

22 findErrors defs = duplicates defs ++ badOrder defs

21

23

@@ -104,4 +106,37 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

104 | length xs < 2 = xs

106 | length xs < 2 = xs

105 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs

107 | otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs

106

108

107− quote tvar = "'" ++ tvar ++ "'"

109+ quote tvar = "'" ++ tvar ++ "'"

110+

111+

112+infiniteTypeAliases :: [Declaration t v] -> [Doc]

113+infiniteTypeAliases decls =

114+ [ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]

115+ where

116+ isInfinite name tipe =

117+ let infinite = isInfinite name in

118+ case tipe of

119+ T.Lambda a b -> infinite a || infinite b

120+ T.Var _ -> False

121+ T.Data name' ts -> name == name' || any infinite ts

122+ T.EmptyRecord -> False

123+ T.Record fields ext -> infinite ext || any (infinite . snd) fields

124+

125+ report decl@(TypeAlias name args tipe) =

126+ P.vcat [ P.text $ eightyCharLines 0 msg1

127+ , indented decl

128+ , P.text $ eightyCharLines 0 msg2

129+ , indented (Datatype name args [(name,[tipe])])

130+ , P.text $ eightyCharLines 0 msg3 ++ "\n"

131+ ]

132+ where

133+ indented decl = P.text "\n " <> pretty decl <> P.text "\n"

134+

135+ msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++

136+ "Notice that it appears in its own definition, so when \

137+ \you expand it, it just keeps getting bigger:"

138+ msg2 = "Try this instead:"

139+ msg3 = "It looks very similar, but an algebraic data type (ADT) \

140+ \actually creates a new type. Unlike with a type alias, this \

141+ \freshly created type is meaningful on its own, so an ADT \

142+ \does not need to be expanded."

compiler/Type/ExtraChecks.hs+41−41

@@ -1,27 +1,25 @@

1-- This module contains checks to be run *after* type inference has

2-- completed successfully. At that point we still need to do occurs

3-- checks and ensure that `main` has an acceptable type.

4−module Type.ExtraChecks (extraChecks) where

4+module Type.ExtraChecks (extraChecks, occursCheck) where

5

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

7+import Control.Monad.State

7import qualified Data.Map as Map

8import qualified Data.Map as Map

8import qualified Data.UnionFind.IO as UF

9import qualified Data.UnionFind.IO as UF

9import Type.Type ( Variable, structure, Term1(..), toSrcType )

10import Type.Type ( Variable, structure, Term1(..), toSrcType )

10−import Type.State (Env)

11+import qualified Type.State as TS

11import qualified Type.Alias as Alias

12import qualified Type.Alias as Alias

12import Text.PrettyPrint as P

13import Text.PrettyPrint as P

13import SourceSyntax.PrettyPrint (pretty)

14import SourceSyntax.PrettyPrint (pretty)

14import SourceSyntax.Type (Type)

15import SourceSyntax.Type (Type)

16+import qualified SourceSyntax.Location as Location

17+import qualified SourceSyntax.Expression as Expr

15import qualified Data.Traversable as Traverse

18import qualified Data.Traversable as Traverse

16

19

17−extraChecks :: Alias.Rules -> Env -> IO (Either [P.Doc] (Map.Map String Type))

20+extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))

18−extraChecks rules env = do

21+extraChecks rules env =

19− eitherEnv <- occursCheck env

20− case eitherEnv of

21− Left errs -> return $ Left errs

22− Right env' ->

23− mainCheck rules <$> Traverse.traverse toSrcType env'

22+ mainCheck rules <$> Traverse.traverse toSrcType env

24−

25

23

26mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)

24mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)

27mainCheck rules env =

25mainCheck rules env =

@@ -39,35 +37,37 @@ mainCheck rules env =

39 , P.text " " ]

37 , P.text " " ]

40 ]

38 ]

41

39

42−occursCheck :: Env -> IO (Either [P.Doc] Env)

43−occursCheck env = do

44− errors <- concat <$> mapM isFinite (Map.toList env)

45− return $ if null errors then Right env else Left errors

46−

47−isFinite :: (String, Variable) -> IO [P.Doc]

40+occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()

48−isFinite (name, var) =

41+occursCheck (name, variable) =

49− do varIsFinite <- go [] var

42+ do vars <- liftIO $ infiniteVars [] variable

50− return $

51− case varIsFinite of

43+ case vars of

52− True -> []

44+ [] -> return ()

53− False -> [ P.vcat [ P.text "Type Error:"

45+ var:_ -> do

54− , P.text $ "Cannot construct infinite type for '" ++ name ++ "'\n"

46+ desc <- liftIO $ UF.descriptor var

55− ]

47+ case structure desc of

56− ]

48+ Nothing ->

49+ modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }

50+ Just struct ->

51+ do liftIO $ UF.setDescriptor var (desc { structure = Nothing })

52+ var' <- liftIO $ UF.fresh desc

53+ TS.addError (Location.NoSpan name) (Just msg) var var'

57 where

54 where

55+ msg = "Infinite types are not allowed"

56+ fallback _ = return $ P.text msg

57+

58− go :: [Variable] -> Variable -> IO Bool

58+ infiniteVars :: [Variable] -> Variable -> IO [Variable]

59− go seen var =

59+ infiniteVars seen var =

60− let check = go (var:seen) in

60+ let go = infiniteVars (var:seen) in

61− case var `elem` seen of

61+ if var `elem` seen

62− True -> return False

62+ then return [var]

63− False -> do

63+ else do

64− desc <- UF.descriptor var

64+ desc <- UF.descriptor var

65− case structure desc of

65+ case structure desc of

66− Nothing -> return True

66+ Nothing -> return []

67− Just struct ->

67+ Just struct ->

68− case struct of

68+ case struct of

69− App1 a b -> (&&) <$> check a <*> check b

69+ App1 a b -> (++) <$> go a <*> go b

70− Fun1 a b -> (&&) <$> check a <*> check b

70+ Fun1 a b -> (++) <$> go a <*> go b

71− Var1 a -> check a

71+ Var1 a -> go a

72− EmptyRecord1 -> return True

72+ EmptyRecord1 -> return []

73− Record1 fields ext -> and <$> mapM check (ext : concat (Map.elems fields))

73+ Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

compiler/Type/Solve.hs+11−6

@@ -9,6 +9,7 @@ import qualified Data.Maybe as Maybe

9import qualified Data.List as List

10import Type.Type

11import Type.Unify

12+import qualified Type.ExtraChecks as EC

12import qualified Type.Environment as Env

13import qualified Type.Environment as Env

13import qualified Type.State as TS

14import qualified Type.State as TS

14import qualified Text.PrettyPrint as P

15import qualified Text.PrettyPrint as P

@@ -118,9 +119,10 @@ solve (L span constraint) =

118

119

119 CLet schemes constraint' -> do

120 CLet schemes constraint' -> do

120 oldEnv <- TS.getEnv

121 oldEnv <- TS.getEnv

121− headers <- mapM (solveScheme span) schemes

122+ headers <- Map.unions `fmap` mapM (solveScheme span) schemes

122− TS.modifyEnv $ \env -> Map.unions (headers ++ [env])

123+ TS.modifyEnv $ \env -> Map.union headers env

123 solve constraint'

124 solve constraint'

125+ mapM EC.occursCheck $ Map.toList headers

124 TS.modifyEnv (\_ -> oldEnv)

126 TS.modifyEnv (\_ -> oldEnv)

125

127

126 CInstance name term -> do

128 CInstance name term -> do

@@ -171,11 +173,13 @@ allDistinct span vars = do

171 let check var = do

173 let check var = do

172 desc <- liftIO $ UF.descriptor var

174 desc <- liftIO $ UF.descriptor var

173 case structure desc of

175 case structure desc of

174− Just _ ->

176+ Just _ -> TS.addError span (Just msg) var var

175− TS.addError span "Cannot generalize something that is not a type variable" var var

177+ where msg = "Cannot generalize something that is not a type variable"

178+

176 Nothing -> do

179 Nothing -> do

177 if mark desc == seen

180 if mark desc == seen

178− then TS.addError span "Duplicate variable during generalization" var var

181+ then let msg = "Duplicate variable during generalization"

182+ in TS.addError span (Just msg) var var

179 else return ()

183 else return ()

180 liftIO $ UF.setDescriptor var (desc { mark = seen })

184 liftIO $ UF.setDescriptor var (desc { mark = seen })

181 mapM_ check vars

185 mapM_ check vars

@@ -186,4 +190,5 @@ isGeneric span var = do

186 desc <- liftIO $ UF.descriptor var

190 desc <- liftIO $ UF.descriptor var

187 if rank desc == noRank

191 if rank desc == noRank

188 then return ()

192 then return ()

193+ else let msg = "Unable to generalize a type variable. It is not unranked"

189− else TS.addError span "Cannot generalize. Variable must have not have a rank." var var

194+ in TS.addError span (Just msg) var var

compiler/Type/State.hs+14−14

@@ -48,7 +48,7 @@ initialState = SS {

48modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }

49modifyPool f = modify $ \state -> state { sPool = f (sPool state) }

50

51−addError span message t1 t2 =

51+addError span hint t1 t2 =

52 modify $ \state -> state { sErrors = makeError : sErrors state }

53 where

54 makeError rules = do

@@ -56,11 +56,13 @@ addError span message t1 t2 =

56 t1' <- prettiest <$> toSrcType t1

57 t2' <- prettiest <$> toSrcType t2

58 return . P.vcat $

59− [ P.text $ "Type error" ++ location ++ ":"

59+ [ display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }

60− , P.vcat . map P.text . lines $ if null message then defaultMessage else message

60+ , case hint of

61− , P.text src

61+ Nothing -> P.text " Could not match the following types:"

62+ Just msg -> P.text $ eightyCharLines 2 $

63+ msg ++ ", so I could not match the following types:"

62− , P.text " Expected Type:" <+> t1'

64+ , P.text " " <> t1'

63− , P.text " Actual Type:" <+> t2' <> P.text "\n"

65+ , P.text " " <> t2'

64 ]

66 ]

65

67

66 location = case span of

68 location = case span of

@@ -69,14 +71,12 @@ addError span message t1 t2 =

69 if line p1 == line p2 then " on line " ++ show (line p1)

71 if line p1 == line p2 then " on line " ++ show (line p1)

70 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

72 else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)

71

73

72− display msg = if null msg then "\n"

74+ display msg =

73− else "\n" ++ unlines (map (" "++) $ lines msg)

74−

75− src = case span of

75+ case lines msg of

76− NoSpan msg -> display msg

76+ [] -> P.text $ "Type error" ++ location ++ ":"

77− Span _ _ msg -> display msg

77+ lines' ->

78−

78+ P.vcat [ P.text $ "Type error" ++ location ++ ", in or near this expression:"

79− defaultMessage = "Something weird is happening with this value:"

79+ , P.text $ " " ++ List.intercalate "\n " lines' ]

80

81

82switchToPool pool = modifyPool (\_ -> pool)

compiler/Type/Unify.hs+16−15

@@ -3,6 +3,7 @@ module Type.Unify (unify) where

3import Type.Type

4import qualified Data.UnionFind.IO as UF

5import qualified Data.Map as Map

6+import qualified Data.Maybe as Maybe

6import qualified Type.State as TS

7import qualified Type.State as TS

7import Control.Arrow (first,second)

8import Control.Arrow (first,second)

8import Control.Monad.State

9import Control.Monad.State

@@ -78,25 +79,26 @@ actuallyUnify span variable1 variable2 = do

78

79

79 unifyNumber svar name

80 unifyNumber svar name

80 | name `elem` ["Int","Float","number"] = flexAndUnify svar

81 | name `elem` ["Int","Float","number"] = flexAndUnify svar

81− | otherwise = TS.addError span "Expecting a number (Int or Float)" variable1 variable2

82+ | otherwise = TS.addError span (Just hint) variable1 variable2

83+ where hint = "A number must be an Int or Float"

82

84

85+ comparableError maybe =

83− comparableError str = TS.addError span (str ++ msg) variable1 variable2

86+ TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2

84− where msg = "Expecting something comparable such as an\n" ++

85− "Int, Float, Char, String, or a list or tuple of comparables."

87+ where msg = "A comparable must be an Int, Float, Char, String, list, or tuple"

86

88

87 unifyComparable var name

89 unifyComparable var name

88 | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var

90 | name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var

89− | otherwise = comparableError ""

91+ | otherwise = comparableError Nothing

90

92

91 unifyComparableStructure varSuper varFlex =

93 unifyComparableStructure varSuper varFlex =

92 do struct <- liftIO $ collectApps varFlex

94 do struct <- liftIO $ collectApps varFlex

93 case struct of

95 case struct of

94− Other -> comparableError ""

96+ Other -> comparableError Nothing

95 List v -> do flexAndUnify varSuper

97 List v -> do flexAndUnify varSuper

96 unify' v =<< liftIO (var $ Is Comparable)

98 unify' v =<< liftIO (var $ Is Comparable)

97 Tuple vs

99 Tuple vs

98 | length vs > 6 ->

100 | length vs > 6 ->

99− comparableError "Cannot compare a tuple with more than 6 elements.\n"

101+ comparableError $ Just "Cannot compare a tuple with more than 6 elements"

100 | otherwise ->

102 | otherwise ->

101 do flexAndUnify varSuper

103 do flexAndUnify varSuper

102 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)

104 cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)

@@ -106,13 +108,12 @@ actuallyUnify span variable1 variable2 = do

106 do struct <- liftIO $ collectApps varFlex

108 do struct <- liftIO $ collectApps varFlex

107 case struct of

109 case struct of

108 List _ -> flexAndUnify varSuper

110 List _ -> flexAndUnify varSuper

109− _ -> comparableError ""

111+ _ -> comparableError Nothing

110

112

111− rigidError variable = TS.addError span msg variable1 variable2

113+ rigidError variable = TS.addError span (Just hint) variable1 variable2

112− where

114+ where hint = "There is a problem with the '" ++

113− msg = concat

114− [ "Cannot unify rigid type variable '", render (pretty Never variable), "'.\n"

115+ render (pretty Never variable) ++

115− , "It is likely that a type annotation is not general enough." ]

116+ "' in the type signature. It currently is not possible to unify type variables that appear in top-level declarations and again in subexpressions"

116

117

117 superUnify =

118 superUnify =

118 case (flex desc1, flex desc2, name desc1, name desc2) of

119 case (flex desc1, flex desc2, name desc1, name desc2) of

@@ -138,7 +139,7 @@ actuallyUnify span variable1 variable2 = do

138

139

139 (Rigid, _, _, _) -> rigidError variable1

140 (Rigid, _, _, _) -> rigidError variable1

140 (_, Rigid, _, _) -> rigidError variable2

141 (_, Rigid, _, _) -> rigidError variable2

141− _ -> TS.addError span "" variable1 variable2

142+ _ -> TS.addError span Nothing variable1 variable2

142

143

143 case (structure desc1, structure desc2) of

144 case (structure desc1, structure desc2) of

144 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge

145 (Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge

@@ -193,5 +194,5 @@ actuallyUnify span variable1 variable2 = do

193 eat (x:xs) (y:ys) = eat xs ys

194 eat (x:xs) (y:ys) = eat xs ys

194 eat xs ys = xs

195 eat xs ys = xs

195

196

196− _ -> TS.addError span "" variable1 variable2

197+ _ -> TS.addError span Nothing variable1 variable2

197

198

libraries/Native/Json.js+1−1

@@ -41,7 +41,7 @@ Elm.Native.Json.make = function(elm) {

41 switch (typeof v) {

42 case 'string' : return { ctor:"String", _0: JS.toString(v) };

43 case 'number' : return { ctor:"Number", _0: JS.toFloat(v) };

44− case 'boolean': return { ctor:"Bool" , _0: JS.toBool(v) };

44+ case 'boolean': return { ctor:"Boolean" , _0: JS.toBool(v) };

45 case 'object' :

46 if (v === null) return { ctor:"Null" };

47 if (v instanceof Array) {

libraries/Native/Signal/Time.js+5−7

@@ -34,13 +34,11 @@ Elm.Native.Time.make = function(elm) {

34 return A3( Signal.lift2, F2(f), isOn, ticker );

35 }

36

37− function everyWhen(t, isOn) {

37+ function every(t) {

38 var clock = Signal.constant(Date.now());

39− var id = setInterval(function tellTime() {

39+ setInterval(function() {

40− if (!elm.notify(clock.id, Date.now())) {

40+ elm.notify(clock.id, Date.now());

41− clearInterval(id);

42− }

43− }, t);

41+ }, t);

44 return clock;

42 return clock;

45 }

43 }

46

44

@@ -56,7 +54,7 @@ Elm.Native.Time.make = function(elm) {

56 return elm.Native.Time.values = {

54 return elm.Native.Time.values = {

57 fpsWhen : F2(fpsWhen),

55 fpsWhen : F2(fpsWhen),

58 fps : function(t) { return fpsWhen(t, Signal.constant(true)); },

56 fps : function(t) { return fpsWhen(t, Signal.constant(true)); },

59− every : function(t) { return everyWhen(t, Signal.constant(true)) },

57+ every : every,

60 delay : NS.delay,

58 delay : NS.delay,

61 timestamp : NS.timestamp,

59 timestamp : NS.timestamp,

62 since : F2(since),

60 since : F2(since),

libraries/Native/Signal/Window.js+12−1

@@ -28,10 +28,21 @@ Elm.Native.Window.make = function(elm) {

28 height.defaultNumberOfKids = 0;

29

30 function resizeIfNeeded() {

31+ // Do not trigger event if the dimensions have not changed.

32+ // This should be most of the time.

31 var w = getWidth();

33 var w = getWidth();

32 var h = getHeight();

34 var h = getHeight();

33 if (dimensions.value._0 === w && dimensions.value._1 === h) return;

35 if (dimensions.value._0 === w && dimensions.value._1 === h) return;

36+

37+ setTimeout(function () {

38+ // Check again to see if the dimensions have changed.

39+ // It is conceivable that the dimensions have changed

40+ // again while some other event was being processed.

41+ var w = getWidth();

42+ var h = getHeight();

43+ if (dimensions.value._0 === w && dimensions.value._1 === h) return;

34− elm.notify(dimensions.id, Tuple2(w,h));

44+ elm.notify(dimensions.id, Tuple2(w,h));

45+ }, 0);

35 }

46 }

36 elm.addListener([dimensions.id], window, 'resize', resizeIfNeeded);

47 elm.addListener([dimensions.id], window, 'resize', resizeIfNeeded);

37

48

libraries/String.elm+1−1

@@ -307,5 +307,5 @@ something.

307

308 fromList ['a','b','c'] == "abc"

309-}

310−fromList : String -> [Char]

310+fromList : [Char] -> String

311fromList = Native.String.fromList

runtime/Init.js+10−4

@@ -31,14 +31,20 @@ function init(display, container, module, moduleToReplace) {

31 // defining state needed for an instance of the Elm RTS

32 var inputs = [];

33

34+ var updateInProgress = false;

34 function notify(id, v) {

35 function notify(id, v) {

36+ if (updateInProgress) {

37+ throw new Error(

38+ 'The notify function has been called synchronously!\n' +

39+ 'This can lead to frames being dropped.\n' +

40+ 'Definitely report this to <https://github.com/evancz/Elm/issues>\n');

41+ }

42+ updateInProgress = true;

35 var timestep = Date.now();

43 var timestep = Date.now();

36− var changed = false;

37 for (var i = inputs.length; i--; ) {

44 for (var i = inputs.length; i--; ) {

38− // order is important here to avoid short-circuiting

39− changed = inputs[i].recv(timestep, id, v) || changed;

45+ inputs[i].recv(timestep, id, v);

40 }

46 }

41− return changed;

47+ updateInProgress = false;

42 }

48 }

43

49

44 var listeners = [];

50 var listeners = [];