2c50fdd · elk · git.iko.soy

git.iko.soy/elk

Merge branch 'dev' into webgl

commit2c50fdd7a66385a99e4af12f2404436f06c0cf4f authorJohn P Mayer Jr <john.p.mayer.jr@gmail.com> dateThu 16 Jan 2014, 22:41 (13 years ago) parentbe9baab 996848c

6 files changed+87−52

compare with master

unifiedsplit

compiler/SourceSyntax/Type.hs+3−1 compiler/Type/ExtraChecks.hs+9−5 libraries/Native/Ports.js+26−15 runtime/Init.js−23 tests/Tests/Property.hs+7−4 tests/Tests/Property/Arbitrary.hs+42−4

compiler/SourceSyntax/Type.hs+3−1

@@ -12,7 +12,7 @@ data Type = Lambda Type Type

1212 | Var String

1313 | Data String [Type]

1414 | Record [(String,Type)] (Maybe String)

15− deriving (Eq, Show)

15+ deriving (Eq)

1616

1717fieldMap :: [(String,a)] -> Map.Map String [a]

1818fieldMap fields =

@@ -27,6 +27,8 @@ listOf t = Data "_List" [t]

2727tupleOf :: [Type] -> Type

2828tupleOf ts = Data ("_Tuple" ++ show (length ts)) ts

2929

30+instance Show Type where

31+ show = render . pretty

3032

3133instance Pretty Type where

3234 pretty tipe =

compiler/Type/ExtraChecks.hs+9−5

@@ -49,9 +49,8 @@ portTypes :: Alias.Rules -> E.LExpr -> Either [P.Doc] ()

4949portTypes rules expr =

5050 const () <$> Expr.checkPorts (check In) (check Out) expr

5151 where

52− check = isValid False False

53− isValid seenFunc seenSignal direction name tipe =

54− let valid = isValid seenFunc seenSignal direction name in

52+ check = isValid True False False

53+ isValid isTopLevel seenFunc seenSignal direction name tipe =

5554 case tipe of

5655 T.Data ctor ts

5756 | isJs ctor || isElm ctor -> mapM_ valid ts

@@ -66,7 +65,8 @@ portTypes rules expr =

6665 Out | seenFunc -> err "higher-order functions"

6766 | seenSignal -> err "signals that contain functions"

6867 | otherwise ->

69− mapM_ (isValid True seenSignal direction name) (T.collectLambdas tipe)

68+ forM_ (T.collectLambdas tipe)

69+ (isValid' True seenSignal direction name)

7070

7171 T.Record _ (Just _) -> err "extended records with free type variables"

7272

@@ -74,6 +74,9 @@ portTypes rules expr =

7474 mapM_ (\(k,v) -> (,) k <$> valid v) fields

7575

7676 where

77+ isValid' = isValid False

78+ valid = isValid' seenFunc seenSignal direction name

79+

7780 isJs ctor =

7881 List.isPrefixOf "JavaScript." ctor

7982 && length (filter (=='.') ctor) == 1

@@ -85,7 +88,8 @@ portTypes rules expr =

8588 handleSignal ts

8689 | seenFunc = err "functions that involve signals"

8790 | seenSignal = err "signals-of-signals"

88− | otherwise = mapM_ (isValid seenFunc True direction name) ts

91+ | isTopLevel = mapM_ (isValid' seenFunc True direction name) ts

92+ | otherwise = err "a signal within a data stucture"

8993

9094 dir inMsg outMsg = case direction of { In -> inMsg ; Out -> outMsg }

9195 txt = P.text . concat

libraries/Native/Ports.js+26−15

@@ -7,18 +7,8 @@ Elm.Native.Ports.make = function(elm) {

77 var Signal = Elm.Signal.make(elm);

99 function incomingSignal(converter) {

10− return function(port) {

11− var base = converter(port.internal.defaultValue);

12− var signal = Signal.constant(base);

13− port.internal.subscribe(function(v) {

14− try {

15− elm.notify(signal.id, converter(v));

16− } catch(e) {

17− port.internal.errorHandler(v);

18− }

19− });

20− return signal;

21− }

10+ converter.isSignal = true;

11+ return converter;

2212 }

2313

2414 function outgoingSignal(converter) {

@@ -42,18 +32,39 @@ Elm.Native.Ports.make = function(elm) {

4232 }

4333

4434 function portIn(name, converter) {

45− var value = elm.ports.incoming[name];

46− if (!value) {

35+ var jsValue = elm.ports.incoming[name];

36+ if (jsValue === undefined) {

4737 throw new Error("Initialization Error: port '" + name +

4838 "' was not given an input!");

4939 }

5040 elm.ports.uses[name] += 1;

5141 try {

52− return converter(value);

42+ var elmValue = converter(jsValue);

5343 } catch(e) {

5444 throw new Error("Initialization Error on port '" + name + "': \n" + e.message);

5545 }

46+

47+ // just return a static value if it is not a signal

48+ if (!converter.isSignal) {

49+ return elmValue;

50+ }

51+

52+ // create a signal if necessary

53+ var signal = Signal.constant(elmValue);

54+ function send(jsValue) {

55+ try {

56+ var elmValue = converter(jsValue);

57+ } catch(e) {

58+ throw new Error("Error sending to port '" + name + "': \n" + e.message);

59+ }

60+ setTimeout(function() {

61+ elm.notify(signal.id, elmValue);

62+ }, 0);

63+ }

64+ elm.ports.outgoing[name] = { send:send };

65+ return signal;

5666 }

67+

5768 function portOut(name, converter, value) {

5869 try {

5970 elm.ports.outgoing[name] = converter(value);

runtime/Init.js−23

@@ -27,29 +27,6 @@ Elm.worker = function(module, ports) {

2727 return init(ElmRuntime.Display.NONE, {}, module, ports || {});

2828};

2929

30−Elm.signal = function(defaultValue, errorHandler) {

31− var subscribers = []

32− function subscribe(handler) {

33− subscribers.push(handler);

34− }

35− function unsubscribe(handler) {

36− subscribers.pop(subscribers.indexOf(handler));

37− }

38− function send(value) {

39− var len = subscribers.length;

40− for (var i = 0; i < len; ++i) {

41− subscribers[i](value);

42− }

43− }

44− return {

45− send:send,

46− internal: { defaultValue:defaultValue,

47− errorHandler:errorHandler,

48− subscribe: subscribe,

49− unsubscribe: unsubscribe }

50− };

51−}

52−

5330function init(display, container, module, ports, moduleToReplace) {

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

5532 var inputs = [];

tests/Tests/Property.hs+7−4

@@ -7,22 +7,25 @@ import Test.Framework.Providers.QuickCheck2

77import Test.HUnit (assert)

88import Test.QuickCheck

99import Text.Parsec.Combinator (eof)

10+import Text.PrettyPrint as P

1011

1112import SourceSyntax.Literal as Lit

1213import SourceSyntax.Pattern as Pat

1314import SourceSyntax.PrettyPrint (Pretty, pretty)

1415import Parse.Helpers (IParser, iParse)

1516import Parse.Literal (literal)

16−import Parse.Pattern (expr)

17+import qualified Parse.Pattern as Pat (expr)

18+import qualified Parse.Type as Type (expr)

1719import Tests.Property.Arbitrary

1820

1921propertyTests :: Test

2022propertyTests =

2123 testGroup "Parse/Print Agreement Tests"

2224 [

23− testCase "Long Pattern test" $ assert (prop_parse_print expr longPat)

25+ testCase "Long Pattern test" $ assert (prop_parse_print Pat.expr longPat)

2426 , testProperty "Literal test" $ prop_parse_print literal

25− , testProperty "Pattern test" $ prop_parse_print expr

27+ , testProperty "Pattern test" $ prop_parse_print Pat.expr

28+ , testProperty "Type test" $ prop_parse_print Type.expr

2629 ]

2730

2831 where

@@ -48,4 +51,4 @@ prop_parse_print p x =

4851 either (const False) (== x) . parse_print p $ x

4952

5053parse_print :: (Pretty a) => IParser a -> a -> Either String a

51−parse_print p = either (Left . show) (Right) . iParse (p <* eof) . show . pretty

54+parse_print p = either (Left . show) (Right) . iParse (p <* eof) . P.renderStyle P.style {mode=P.LeftMode} . pretty

tests/Tests/Property/Arbitrary.hs+42−4

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

1−{-# OPTIONS_GHC -fno-warn-orphans #-}

1+{-# OPTIONS_GHC -W -fno-warn-orphans #-}

22module Tests.Property.Arbitrary where

44import Control.Applicative ((<$>), (<*>), pure)

@@ -10,6 +10,7 @@ import qualified Parse.Helpers (reserveds)

1010

1111import SourceSyntax.Literal

1212import SourceSyntax.Pattern

13+import SourceSyntax.Type hiding (listOf)

1314

1415instance Arbitrary Literal where

1516 arbitrary = oneof [ IntNum <$> arbitrary

@@ -43,8 +44,8 @@ instance Arbitrary Pattern where

4344 ]

4445 where sizedPats = do

4546 len <- choose (0,n)

46− let m = n `div` len in

47− vectorOf len $ pat m

47+ let m = n `div` (len + 1)

48+ vectorOf len $ pat m

4849

4950 shrink pat = case pat of

5051 PAnything -> []

@@ -53,7 +54,44 @@ instance Arbitrary Pattern where

5354 PLiteral l -> PLiteral <$> shrink l

5455 PAlias s p -> p : (PAlias <$> shrinkWHead s <*> shrink p)

5556 PData s ps -> ps ++ (PData <$> shrinkWHead s <*> shrink ps)

56− where shrinkWHead (x:xs) = (x:) <$> shrink xs

57+

58+shrinkWHead :: Arbitrary a => [a] -> [[a]]

59+shrinkWHead [] = error "Should be nonempty"

60+shrinkWHead (x:xs) = (x:) <$> shrink xs

61+

62+instance Arbitrary Type where

63+ arbitrary = sized tipe

64+ where tipe :: Int -> Gen Type

65+ tipe n = oneof [ Lambda <$> depthTipe <*> depthTipe

66+ , Var <$> lowVar

67+ , Data <$> capVar <*> depthTipes

68+ , Record <$> fields <*> pure Nothing

69+ , Record <$> fields1 <*> (Just <$> lowVar)

70+ ]

71+ where depthTipe = choose (0,n) >>= tipe

72+ depthTipes = do

73+ len <- choose (0,n)

74+ let m = n `div` (len + 1)

75+ vectorOf len $ tipe m

76+

77+ field = (,) <$> lowVar <*> depthTipe

78+ fields = do

79+ len <- choose (0,n)

80+ let m = n `div` (len + 1)

81+ vectorOf len $ (,) <$> lowVar <*> tipe m

82+ fields1 = (:) <$> field <*> fields

83+

84+ shrink tipe = case tipe of

85+ Lambda s t -> s : t : (Lambda <$> shrink s <*> shrink t)

86+ Var _ -> []

87+ Data n ts -> ts ++ (Data <$> shrinkWHead n <*> shrink ts)

88+ Record fs t -> map snd fs ++ case t of

89+ Nothing -> Record <$> shrinkList shrinkField fs <*> pure Nothing

90+ Just _ ->

91+ do

92+ fields <- filter (not . null) $ shrinkList shrinkField fs

93+ return $ Record fields t

94+ where shrinkField (n,t) = (,) <$> shrinkWHead n <*> shrink t

5795

5896lowVar :: Gen String

5997lowVar = notReserved $ (:) <$> lower <*> listOf varLetter