yogsototh/elm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'master' into dev

Browse source
This commit is contained in:
Evan Czaplicki 2013-11-19 22:34:08 -08:00
commit bccfece2c1
12 changed files with 165 additions and 94 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
README.md
View file

@ -3,6 +3,10 @@ Learn about the Elm programming language at [elm-lang.org](http://elm-lang.org/)
## Install
**Note for OS X 10.9 Maverics:** you must follow
[these directions](http://justtesting.org/post/64947952690/the-glasgow-haskell-compiler-ghc-on-os-x-10-9)
before continuing!
Download the [Haskell Platform 2012.2.0.0 or later](http://hackage.haskell.org/platform/).
Once the Haskell Platform is installed:

11
compiler/SourceSyntax/PrettyPrint.hs
View file

@ -21,3 +21,14 @@ variable x =
reprime :: String -> String
reprime = map (\c -> if c == '$' then '\'' else c)
eightyCharLines :: Int -> String -> String
eightyCharLines indent message = answer
where
(answer,_,_) = foldl step (replicate (indent-1) ' ', indent-1, "") chunks
chunks = map (\w -> (w, length w)) (words message)
spaces = replicate indent ' '
step (sentence, slen, space) (word, wlen)
| slen + wlen > 79 = (sentence ++ "\n" ++ spaces ++ word, indent + wlen, " ")
| otherwise = (sentence ++ space ++ word, slen + wlen + length space, " ")

39
compiler/Transform/Check.hs
View file

@ -15,7 +15,9 @@ import Text.PrettyPrint as P
mistakes :: (Data t, Data v) => [Declaration t v] -> [Doc]
mistakes decls =
illFormedTypes decls ++ map P.text (concatMap findErrors (getLets decls))
concat [ infiniteTypeAliases decls
, illFormedTypes decls
, map P.text (concatMap findErrors (getLets decls)) ]
where
findErrors defs = duplicates defs ++ badOrder defs
@ -104,4 +106,37 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
| length xs < 2 = xs
| otherwise = zipWith (++) (replicate (length xs - 1) "" ++ ["and "]) xs
quote tvar = "'" ++ tvar ++ "'"
quote tvar = "'" ++ tvar ++ "'"
infiniteTypeAliases :: [Declaration t v] -> [Doc]
infiniteTypeAliases decls =
[ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]
where
isInfinite name tipe =
let infinite = isInfinite name in
case tipe of
T.Lambda a b -> infinite a || infinite b
T.Var _ -> False
T.Data name' ts -> name == name' || any infinite ts
T.EmptyRecord -> False
T.Record fields ext -> infinite ext || any (infinite . snd) fields
report decl@(TypeAlias name args tipe) =
P.vcat [ P.text $ eightyCharLines 0 msg1
, indented decl
, P.text $ eightyCharLines 0 msg2
, indented (Datatype name args [(name,[tipe])])
, P.text $ eightyCharLines 0 msg3 ++ "\n"
]
where
indented decl = P.text "\n " <> pretty decl <> P.text "\n"
msg1 = "Type alias '" ++ name ++ "' is an infinite type. " ++
"Notice that it appears in its own definition, so when \
\you expand it, it just keeps getting bigger:"
msg2 = "Try this instead:"
msg3 = "It looks very similar, but an algebraic data type (ADT) \
\actually creates a new type. Unlike with a type alias, this \
\freshly created type is meaningful on its own, so an ADT \
\does not need to be expanded."

82
compiler/Type/ExtraChecks.hs
View file

@ -1,27 +1,25 @@
-- This module contains checks to be run *after* type inference has
-- completed successfully. At that point we still need to do occurs
-- checks and ensure that `main` has an acceptable type.
module Type.ExtraChecks (extraChecks) where
module Type.ExtraChecks (extraChecks, occursCheck) where
import Control.Applicative ((<$>),(<*>))
import Control.Monad.State
import qualified Data.Map as Map
import qualified Data.UnionFind.IO as UF
import Type.Type ( Variable, structure, Term1(..), toSrcType )
import Type.State (Env)
import qualified Type.State as TS
import qualified Type.Alias as Alias
import Text.PrettyPrint as P
import SourceSyntax.PrettyPrint (pretty)
import SourceSyntax.Type (Type)
import qualified SourceSyntax.Location as Location
import qualified SourceSyntax.Expression as Expr
import qualified Data.Traversable as Traverse
extraChecks :: Alias.Rules -> Env -> IO (Either [P.Doc] (Map.Map String Type))
extraChecks rules env = do
eitherEnv <- occursCheck env
case eitherEnv of
Left errs -> return $ Left errs
Right env' ->
mainCheck rules <$> Traverse.traverse toSrcType env'
extraChecks :: Alias.Rules -> TS.Env -> IO (Either [P.Doc] (Map.Map String Type))
extraChecks rules env =
mainCheck rules <$> Traverse.traverse toSrcType env
mainCheck :: Alias.Rules -> (Map.Map String Type) -> Either [P.Doc] (Map.Map String Type)
mainCheck rules env =
@ -39,35 +37,37 @@ mainCheck rules env =
, P.text " " ]
]
occursCheck :: Env -> IO (Either [P.Doc] Env)
occursCheck env = do
errors <- concat <$> mapM isFinite (Map.toList env)
return $ if null errors then Right env else Left errors
isFinite :: (String, Variable) -> IO [P.Doc]
isFinite (name, var) =
do varIsFinite <- go [] var
return $
case varIsFinite of
True -> []
False -> [ P.vcat [ P.text "Type Error:"
, P.text $ "Cannot construct infinite type for '" ++ name ++ "'\n"
]
]
occursCheck :: (String, Variable) -> StateT TS.SolverState IO ()
occursCheck (name, variable) =
do vars <- liftIO $ infiniteVars [] variable
case vars of
[] -> return ()
var:_ -> do
desc <- liftIO $ UF.descriptor var
case structure desc of
Nothing ->
modify $ \state -> state { TS.sErrors = fallback : TS.sErrors state }
Just struct ->
do liftIO $ UF.setDescriptor var (desc { structure = Nothing })
var' <- liftIO $ UF.fresh desc
TS.addError (Location.NoSpan name) (Just msg) var var'
where
go :: [Variable] -> Variable -> IO Bool
go seen var =
let check = go (var:seen) in
case var `elem` seen of
True -> return False
False -> do
desc <- UF.descriptor var
case structure desc of
Nothing -> return True
Just struct ->
case struct of
App1 a b -> (&&) <$> check a <*> check b
Fun1 a b -> (&&) <$> check a <*> check b
Var1 a -> check a
EmptyRecord1 -> return True
Record1 fields ext -> and <$> mapM check (ext : concat (Map.elems fields))
msg = "Infinite types are not allowed"
fallback _ = return $ P.text msg
infiniteVars :: [Variable] -> Variable -> IO [Variable]
infiniteVars seen var =
let go = infiniteVars (var:seen) in
if var `elem` seen
then return [var]
else do
desc <- UF.descriptor var
case structure desc of
Nothing -> return []
Just struct ->
case struct of
App1 a b -> (++) <$> go a <*> go b
Fun1 a b -> (++) <$> go a <*> go b
Var1 a -> go a
EmptyRecord1 -> return []
Record1 fields ext -> concat <$> mapM go (ext : concat (Map.elems fields))

17
compiler/Type/Solve.hs
View file

@ -9,6 +9,7 @@ import qualified Data.Maybe as Maybe
import qualified Data.List as List
import Type.Type
import Type.Unify
import qualified Type.ExtraChecks as EC
import qualified Type.Environment as Env
import qualified Type.State as TS
import qualified Text.PrettyPrint as P
@ -118,9 +119,10 @@ solve (L span constraint) =
CLet schemes constraint' -> do
oldEnv <- TS.getEnv
headers <- mapM (solveScheme span) schemes
TS.modifyEnv $ \env -> Map.unions (headers ++ [env])
headers <- Map.unions `fmap` mapM (solveScheme span) schemes
TS.modifyEnv $ \env -> Map.union headers env
solve constraint'
mapM EC.occursCheck $ Map.toList headers
TS.modifyEnv (\_ -> oldEnv)
CInstance name term -> do
@ -171,11 +173,13 @@ allDistinct span vars = do
let check var = do
desc <- liftIO $ UF.descriptor var
case structure desc of
Just _ ->
TS.addError span "Cannot generalize something that is not a type variable" var var
Just _ -> TS.addError span (Just msg) var var
where msg = "Cannot generalize something that is not a type variable"
Nothing -> do
if mark desc == seen
then TS.addError span "Duplicate variable during generalization" var var
then let msg = "Duplicate variable during generalization"
in TS.addError span (Just msg) var var
else return ()
liftIO $ UF.setDescriptor var (desc { mark = seen })
mapM_ check vars
@ -186,4 +190,5 @@ isGeneric span var = do
desc <- liftIO $ UF.descriptor var
if rank desc == noRank
then return ()
else TS.addError span "Cannot generalize. Variable must have not have a rank." var var
else let msg = "Unable to generalize a type variable. It is not unranked"
in TS.addError span (Just msg) var var

28
compiler/Type/State.hs
View file

@ -48,7 +48,7 @@ initialState = SS {
modifyEnv f = modify $ \state -> state { sEnv = f (sEnv state) }
modifyPool f = modify $ \state -> state { sPool = f (sPool state) }
addError span message t1 t2 =
addError span hint t1 t2 =
modify $ \state -> state { sErrors = makeError : sErrors state }
where
makeError rules = do
@ -56,11 +56,13 @@ addError span message t1 t2 =
t1' <- prettiest <$> toSrcType t1
t2' <- prettiest <$> toSrcType t2
return . P.vcat $
[ P.text $ "Type error" ++ location ++ ":"
, P.vcat . map P.text . lines $ if null message then defaultMessage else message
, P.text src
, P.text " Expected Type:" <+> t1'
, P.text " Actual Type:" <+> t2' <> P.text "\n"
[ display $ case span of { NoSpan msg -> msg ; Span _ _ msg -> msg }
, case hint of
Nothing -> P.text " Could not match the following types:"
Just msg -> P.text $ eightyCharLines 2 $
msg ++ ", so I could not match the following types:"
, P.text " " <> t1'
, P.text " " <> t2'
]
location = case span of
@ -69,14 +71,12 @@ addError span message t1 t2 =
if line p1 == line p2 then " on line " ++ show (line p1)
else " between lines " ++ show (line p1) ++ " and " ++ show (line p2)
display msg = if null msg then "\n"
else "\n" ++ unlines (map (" "++) $ lines msg)
src = case span of
NoSpan msg -> display msg
Span _ _ msg -> display msg
defaultMessage = "Something weird is happening with this value:"
display msg =
case lines msg of
[] -> P.text $ "Type error" ++ location ++ ":"
lines' ->
P.vcat [ P.text $ "Type error" ++ location ++ ", in or near this expression:"
, P.text $ " " ++ List.intercalate "\n " lines' ]
switchToPool pool = modifyPool (\_ -> pool)

31
compiler/Type/Unify.hs
View file

@ -3,6 +3,7 @@ module Type.Unify (unify) where
import Type.Type
import qualified Data.UnionFind.IO as UF
import qualified Data.Map as Map
import qualified Data.Maybe as Maybe
import qualified Type.State as TS
import Control.Arrow (first,second)
import Control.Monad.State
@ -78,25 +79,26 @@ actuallyUnify span variable1 variable2 = do
unifyNumber svar name
| name `elem` ["Int","Float","number"] = flexAndUnify svar
| otherwise = TS.addError span "Expecting a number (Int or Float)" variable1 variable2
| otherwise = TS.addError span (Just hint) variable1 variable2
where hint = "A number must be an Int or Float"
comparableError str = TS.addError span (str ++ msg) variable1 variable2
where msg = "Expecting something comparable such as an\n" ++
"Int, Float, Char, String, or a list or tuple of comparables."
comparableError maybe =
TS.addError span (Just $ Maybe.fromMaybe msg maybe) variable1 variable2
where msg = "A comparable must be an Int, Float, Char, String, list, or tuple"
unifyComparable var name
| name `elem` ["Int","Float","Char","String","comparable"] = flexAndUnify var
| otherwise = comparableError ""
| otherwise = comparableError Nothing
unifyComparableStructure varSuper varFlex =
do struct <- liftIO $ collectApps varFlex
case struct of
Other -> comparableError ""
Other -> comparableError Nothing
List v -> do flexAndUnify varSuper
unify' v =<< liftIO (var $ Is Comparable)
Tuple vs
| length vs > 6 ->
comparableError "Cannot compare a tuple with more than 6 elements.\n"
comparableError $ Just "Cannot compare a tuple with more than 6 elements"
| otherwise ->
do flexAndUnify varSuper
cmpVars <- liftIO $ forM [1..length vs] $ \_ -> var (Is Comparable)
@ -106,13 +108,12 @@ actuallyUnify span variable1 variable2 = do
do struct <- liftIO $ collectApps varFlex
case struct of
List _ -> flexAndUnify varSuper
_ -> comparableError ""
_ -> comparableError Nothing
rigidError variable = TS.addError span msg variable1 variable2
where
msg = concat
[ "Cannot unify rigid type variable '", render (pretty Never variable), "'.\n"
, "It is likely that a type annotation is not general enough." ]
rigidError variable = TS.addError span (Just hint) variable1 variable2
where hint = "There is a problem with the '" ++
render (pretty Never variable) ++
"' in the type signature. It currently is not possible to unify type variables that appear in top-level declarations and again in subexpressions"
superUnify =
case (flex desc1, flex desc2, name desc1, name desc2) of
@ -138,7 +139,7 @@ actuallyUnify span variable1 variable2 = do
(Rigid, _, _, _) -> rigidError variable1
(_, Rigid, _, _) -> rigidError variable2
_ -> TS.addError span "" variable1 variable2
_ -> TS.addError span Nothing variable1 variable2
case (structure desc1, structure desc2) of
(Nothing, Nothing) | flex desc1 == Flexible && flex desc1 == Flexible -> merge
@ -193,5 +194,5 @@ actuallyUnify span variable1 variable2 = do
eat (x:xs) (y:ys) = eat xs ys
eat xs ys = xs
_ -> TS.addError span "" variable1 variable2
_ -> TS.addError span Nothing variable1 variable2

2
libraries/Native/Json.js
View file

@ -41,7 +41,7 @@ Elm.Native.Json.make = function(elm) {
switch (typeof v) {
case 'string' : return { ctor:"String", _0: JS.toString(v) };
case 'number' : return { ctor:"Number", _0: JS.toFloat(v) };
case 'boolean': return { ctor:"Bool" , _0: JS.toBool(v) };
case 'boolean': return { ctor:"Boolean" , _0: JS.toBool(v) };
case 'object' :
if (v === null) return { ctor:"Null" };
if (v instanceof Array) {

12
libraries/Native/Signal/Time.js
View file

@ -34,13 +34,11 @@ Elm.Native.Time.make = function(elm) {
return A3( Signal.lift2, F2(f), isOn, ticker );
}
function everyWhen(t, isOn) {
function every(t) {
var clock = Signal.constant(Date.now());
var id = setInterval(function tellTime() {
if (!elm.notify(clock.id, Date.now())) {
clearInterval(id);
}
}, t);
setInterval(function() {
elm.notify(clock.id, Date.now());
}, t);
return clock;
}
@ -56,7 +54,7 @@ Elm.Native.Time.make = function(elm) {
return elm.Native.Time.values = {
fpsWhen : F2(fpsWhen),
fps : function(t) { return fpsWhen(t, Signal.constant(true)); },
every : function(t) { return everyWhen(t, Signal.constant(true)) },
every : every,
delay : NS.delay,
timestamp : NS.timestamp,
since : F2(since),

13
libraries/Native/Signal/Window.js
View file

@ -28,10 +28,21 @@ Elm.Native.Window.make = function(elm) {
height.defaultNumberOfKids = 0;
function resizeIfNeeded() {
// Do not trigger event if the dimensions have not changed.
// This should be most of the time.
var w = getWidth();
var h = getHeight();
if (dimensions.value._0 === w && dimensions.value._1 === h) return;
elm.notify(dimensions.id, Tuple2(w,h));
setTimeout(function () {
// Check again to see if the dimensions have changed.
// It is conceivable that the dimensions have changed
// again while some other event was being processed.
var w = getWidth();
var h = getHeight();
if (dimensions.value._0 === w && dimensions.value._1 === h) return;
elm.notify(dimensions.id, Tuple2(w,h));
}, 0);
}
elm.addListener([dimensions.id], window, 'resize', resizeIfNeeded);

2
libraries/String.elm
View file

@ -307,5 +307,5 @@ something.
fromList ['a','b','c'] == "abc"
-}
fromList : String -> [Char]
fromList : [Char] -> String
fromList = Native.String.fromList

18
runtime/Init.js
View file

@ -31,14 +31,20 @@ function init(display, container, module, moduleToReplace) {
// defining state needed for an instance of the Elm RTS
var inputs = [];
var updateInProgress = false;
function notify(id, v) {
var timestep = Date.now();
var changed = false;
for (var i = inputs.length; i--; ) {
// order is important here to avoid short-circuiting
changed = inputs[i].recv(timestep, id, v) || changed;
if (updateInProgress) {
throw new Error(
'The notify function has been called synchronously!\n' +
'This can lead to frames being dropped.\n' +
'Definitely report this to <https://github.com/evancz/Elm/issues>\n');
}
return changed;
updateInProgress = true;
var timestep = Date.now();
for (var i = inputs.length; i--; ) {
inputs[i].recv(timestep, id, v);
}
updateInProgress = false;
}
var listeners = [];