2a954d7 · elk · git.iko.soy

README.md+4

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

33

44## Install

55

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+

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

711Once the Haskell Platform is installed:

812

compiler/SourceSyntax/PrettyPrint.hs+11

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

2121

2222reprime :: String -> String

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

24+

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

26+eightyCharLines indent message = answer

27+ where

28+ (answer,_,_) = foldl step (spaces, 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

1515

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

1717mistakes decls =

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

18+ concat [ infiniteTypeAliases decls

19+ , illFormedTypes decls

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

1921 where

2022 findErrors defs = duplicates defs ++ badOrder defs

2123

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

104106 | length xs < 2 = xs

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

106108

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

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

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

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

4−module Type.ExtraChecks (extraChecks) where

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

55

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

7+import Control.Monad.State

78import qualified Data.Map as Map

89import qualified Data.UnionFind.IO as UF

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

10−import Type.State (Env)

11+import qualified Type.State as TS

1112import qualified Type.Alias as Alias

1213import Text.PrettyPrint as P

1314import SourceSyntax.PrettyPrint (pretty)

1415import SourceSyntax.Type (Type)

16+import qualified SourceSyntax.Location as Location

17+import qualified SourceSyntax.Expression as Expr

1518import qualified Data.Traversable as Traverse

1619

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

18−extraChecks rules env = do

19− eitherEnv <- occursCheck env

20− case eitherEnv of

21− Left errs -> return $ Left errs

22− Right env' ->

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

24−

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

21+extraChecks rules env =

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

2523

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

2725mainCheck rules env =

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

3937 , P.text " " ]

4038 ]

4139

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]

48−isFinite (name, var) =

49− do varIsFinite <- go [] var

50− return $

51− case varIsFinite of

52− True -> []

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

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

55− ]

56− ]

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

41+occursCheck (name, variable) =

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

43+ case vars of

44+ [] -> return ()

45+ var:_ -> do

46+ desc <- liftIO $ UF.descriptor var

47+ case structure desc of

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'

5754 where

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

59− go seen var =

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

61− case var `elem` seen of

62− True -> return False

63− False -> do

64− desc <- UF.descriptor var

65− case structure desc of

66− Nothing -> return True

67− Just struct ->

68− case struct of

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

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

71− Var1 a -> check a

72− EmptyRecord1 -> return True

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

55+ msg = "Infinite types are not allowed"

56+ fallback _ = return $ P.text msg

57+

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

59+ infiniteVars seen var =

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

61+ if var `elem` seen

62+ then return [var]

63+ else do

64+ desc <- UF.descriptor var

65+ case structure desc of

66+ Nothing -> return []

67+ Just struct ->

68+ case struct of

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

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

71+ Var1 a -> go a

72+ EmptyRecord1 -> return []

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

99import qualified Data.List as List

1010import Type.Type

1111import Type.Unify

12+import qualified Type.ExtraChecks as EC

1213import qualified Type.Environment as Env

1314import qualified Type.State as TS

1415import qualified Text.PrettyPrint as P

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

118119

119120 CLet schemes constraint' -> do

120121 oldEnv <- TS.getEnv

121− headers <- mapM (solveScheme span) schemes

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

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

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

123124 solve constraint'

125+ mapM EC.occursCheck $ Map.toList headers

124126 TS.modifyEnv (\_ -> oldEnv)

125127

126128 CInstance name term -> do

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

171173 let check var = do

172174 desc <- liftIO $ UF.descriptor var

173175 case structure desc of

174− Just _ ->

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

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

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

178+

176179 Nothing -> do

177180 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

179183 else return ()

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

181185 mapM_ check vars

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

186190 desc <- liftIO $ UF.descriptor var

187191 if rank desc == noRank

188192 then return ()

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

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

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

compiler/Type/State.hs+14−14

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

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

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

5050

51−addError span message t1 t2 =

51+addError span hint t1 t2 =

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

5353 where

5454 makeError rules = do

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

5656 t1' <- prettiest <$> toSrcType t1

5757 t2' <- prettiest <$> toSrcType t2

5858 return . P.vcat $

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

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

61− , P.text src

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

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

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

60+ , case hint of

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

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

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

6466 ]

6567

6668 location = case span of

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

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

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

7173

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

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

74−

75− src = case span of

76− NoSpan msg -> display msg

77− Span _ _ msg -> display msg

78−

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

74+ display msg =

75+ case lines msg of

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

77+ lines' ->

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

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

8080

8181

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

compiler/Type/Unify.hs+16−15

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

33import Type.Type

44import qualified Data.UnionFind.IO as UF

55import qualified Data.Map as Map

6+import qualified Data.Maybe as Maybe

67import qualified Type.State as TS

78import Control.Arrow (first,second)

89import Control.Monad.State

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

7879

7980 unifyNumber svar name

8081 | 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"

8284

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

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

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

85+ comparableError maybe =

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

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

8688

8789 unifyComparable var name

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

89− | otherwise = comparableError ""

91+ | otherwise = comparableError Nothing

9092

9193 unifyComparableStructure varSuper varFlex =

9294 do struct <- liftIO $ collectApps varFlex

9395 case struct of

94− Other -> comparableError ""

96+ Other -> comparableError Nothing

9597 List v -> do flexAndUnify varSuper

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

9799 Tuple vs

98100 | 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"

100102 | otherwise ->

101103 do flexAndUnify varSuper

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

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

106108 do struct <- liftIO $ collectApps varFlex

107109 case struct of

108110 List _ -> flexAndUnify varSuper

109− _ -> comparableError ""

111+ _ -> comparableError Nothing

110112

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

112− where

113− msg = concat

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

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

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

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

115+ render (pretty Never variable) ++

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

116117

117118 superUnify =

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

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

138139

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

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

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

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

142143

143144 case (structure desc1, structure desc2) of

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

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

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

194195 eat xs ys = xs

195196

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

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

197198

libraries/Native/Json.js+1−1

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

4141 switch (typeof v) {

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

4343 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) };

4545 case 'object' :

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

4747 if (v instanceof Array) {

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

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

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

3535 }

3636

37− function everyWhen(t, isOn) {

37+ function every(t) {

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

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

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

41− clearInterval(id);

42− }

43− }, t);

39+ setInterval(function() {

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

41+ }, t);

4442 return clock;

4543 }

4644

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

5654 return elm.Native.Time.values = {

5755 fpsWhen : F2(fpsWhen),

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

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

57+ every : every,

6058 delay : NS.delay,

6159 timestamp : NS.timestamp,

6260 since : F2(since),

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

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

2828 height.defaultNumberOfKids = 0;

2929

3030 function resizeIfNeeded() {

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

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

3133 var w = getWidth();

3234 var h = getHeight();

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

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

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;

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

45+ }, 0);

3546 }

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

3748

libraries/String.elm+1−1

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

307307

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

309309-}

310−fromList : String -> [Char]

310+fromList : [Char] -> String

311311fromList = Native.String.fromList

runtime/Init.js+10−4

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

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

3232 var inputs = [];

3333

34+ var updateInProgress = false;

3435 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;

3543 var timestep = Date.now();

36− var changed = false;

3744 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);

4046 }

41− return changed;

47+ updateInProgress = false;

4248 }

4349

4450 var listeners = [];