2c50fdd · elk · git.iko.soy

compiler/SourceSyntax/Type.hs+3−1

compare with master

unifiedsplit

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

12 | Var String

13 | Data String [Type]

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

15− deriving (Eq, Show)

15+ deriving (Eq)

16

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

18fieldMap fields =

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

27tupleOf :: [Type] -> Type

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

29

30+instance Show Type where

31+ show = render . pretty

30

32

31instance Pretty Type where

33instance Pretty Type where

32 pretty tipe =

34 pretty tipe =

compiler/Type/ExtraChecks.hs+9−5

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

49portTypes rules expr =

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

51 where

52− check = isValid False False

52+ check = isValid True False False

53− isValid seenFunc seenSignal direction name tipe =

53+ isValid isTopLevel seenFunc seenSignal direction name tipe =

54− let valid = isValid seenFunc seenSignal direction name in

55 case tipe of

54 case tipe of

56 T.Data ctor ts

55 T.Data ctor ts

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

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

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

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

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

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

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

68 | otherwise ->

67 | otherwise ->

68+ forM_ (T.collectLambdas tipe)

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

69+ (isValid' True seenSignal direction name)

70

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

72

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

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

75

76 where

77+ isValid' = isValid False

78+ valid = isValid' seenFunc seenSignal direction name

79+

77 isJs ctor =

80 isJs ctor =

78 List.isPrefixOf "JavaScript." ctor

81 List.isPrefixOf "JavaScript." ctor

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

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

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

85 handleSignal ts

88 handleSignal ts

86 | seenFunc = err "functions that involve signals"

89 | seenFunc = err "functions that involve signals"

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

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

89

93

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

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

91 txt = P.text . concat

95 txt = P.text . concat

libraries/Native/Ports.js+26−15

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

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

8

9 function incomingSignal(converter) {

10− return function(port) {

10+ converter.isSignal = true;

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

11+ return converter;

16− } catch(e) {

17− port.internal.errorHandler(v);

18− }

19− });

20− return signal;

21− }

22 }

12 }

23

13

24 function outgoingSignal(converter) {

14 function outgoingSignal(converter) {

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

42 }

32 }

43

33

44 function portIn(name, converter) {

34 function portIn(name, converter) {

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

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

46− if (!value) {

36+ if (jsValue === undefined) {

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

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

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

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

49 }

39 }

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

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

51 try {

41 try {

52− return converter(value);

42+ var elmValue = converter(jsValue);

53 } catch(e) {

43 } catch(e) {

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

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

55 }

45 }

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;

56 }

66 }

67+

57 function portOut(name, converter, value) {

68 function portOut(name, converter, value) {

58 try {

69 try {

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

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

runtime/Init.js−23

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

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

28};

29

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−

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

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

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

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

55 var inputs = [];

32 var inputs = [];

tests/Tests/Property.hs+7−4

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

7import Test.HUnit (assert)

8import Test.QuickCheck

9import Text.Parsec.Combinator (eof)

10+import Text.PrettyPrint as P

10

11

11import SourceSyntax.Literal as Lit

12import SourceSyntax.Literal as Lit

12import SourceSyntax.Pattern as Pat

13import SourceSyntax.Pattern as Pat

13import SourceSyntax.PrettyPrint (Pretty, pretty)

14import SourceSyntax.PrettyPrint (Pretty, pretty)

14import Parse.Helpers (IParser, iParse)

15import Parse.Helpers (IParser, iParse)

15import Parse.Literal (literal)

16import Parse.Literal (literal)

16−import Parse.Pattern (expr)

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

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

17import Tests.Property.Arbitrary

19import Tests.Property.Arbitrary

18

20

19propertyTests :: Test

21propertyTests :: Test

20propertyTests =

22propertyTests =

21 testGroup "Parse/Print Agreement Tests"

23 testGroup "Parse/Print Agreement Tests"

22 [

24 [

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

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

24 , testProperty "Literal test" $ prop_parse_print literal

26 , 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

26 ]

29 ]

27

30

28 where

31 where

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

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

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

49

52

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

53parse_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 #-}

2module Tests.Property.Arbitrary where

3

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

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

10

11import SourceSyntax.Literal

12import SourceSyntax.Pattern

13+import SourceSyntax.Type hiding (listOf)

13

14

14instance Arbitrary Literal where

15instance Arbitrary Literal where

15 arbitrary = oneof [ IntNum <$> arbitrary

16 arbitrary = oneof [ IntNum <$> arbitrary

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

43 ]

44 ]

44 where sizedPats = do

45 where sizedPats = do

45 len <- choose (0,n)

46 len <- choose (0,n)

46− let m = n `div` len in

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

47− vectorOf len $ pat m

48+ vectorOf len $ pat m

48

49

49 shrink pat = case pat of

50 shrink pat = case pat of

50 PAnything -> []

51 PAnything -> []

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

53 PLiteral l -> PLiteral <$> shrink l

54 PLiteral l -> PLiteral <$> shrink l

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

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

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

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

57+

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

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

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

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

57

95

58lowVar :: Gen String

96lowVar :: Gen String

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

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