ec2e0e3 · rowtype-yoga/purescript-native

examples/passing/Eff.pursnew file+59

compare with golang

unifiedsplit

@@ -0,0 +1,59 @@

1+module Kinds where

2+

3+-- Eff Monad

4+

5+foreign import data Eff :: # ! -> * -> *

6+

7+foreign import ret :: forall e a. a -> Eff e a

8+

9+foreign import (>>=) :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

10+

11+type Pure a = forall e. Eff e a

12+

13+foreign import runPure :: forall a. Pure a -> a

14+

15+-- Errors

16+

17+foreign import data Error :: * -> !

18+

19+foreign import throwError :: forall e r. e -> Eff (err :: Error e | r) {}

20+

21+foreign import catchError :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a

22+

23+-- State

24+

25+foreign import data State :: * -> !

26+

27+foreign import get :: forall s r. Eff (state :: State s | r) s

28+

29+foreign import set :: forall s r. s -> Eff (state :: State s | r) {}

30+

31+foreign import runState :: forall s r a. s -> Eff (state :: State s | r) a -> Eff r { value :: a, state :: s }

32+

33+-- ST

34+

35+foreign import data ST :: * -> !

36+

37+foreign import data STRef :: * -> * -> *

38+

39+foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

40+

41+foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

42+

43+foreign import modifySTRef :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}

44+

45+foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

46+

47+-- Tests

48+

49+test1 = runPure (runState 0 (catchError (\s -> ret 0)

50+ (get >>= \s ->

51+ throwError "Error!" >>= \_ ->

52+ set (s + 1) >>= \_ ->

53+ ret s)))

54+

55+test2 = runPure (runST (

56+ newSTRef 0 >>= \ref ->

57+ modifySTRef (\n -> n + 1) ref >>= \_ ->

58+ readSTRef ref))

59+

src/Language/PureScript/Kinds.hs+2−1

@@ -22,5 +22,6 @@ import Language.PureScript.Unknown

22data Kind

23 = KUnknown (Unknown Kind)

24 | Star

25+ | Bang

25− | Row

26+ | Row Kind

26 | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)

27 | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)

src/Language/PureScript/Parser/Kinds.hs+5−4

@@ -26,16 +26,17 @@ import qualified Text.Parsec.Expr as P

26parseStar :: P.Parsec String ParseState Kind

27parseStar = const Star <$> lexeme (P.char '*')

28

29−parseRow :: P.Parsec String ParseState Kind

29+parseBang :: P.Parsec String ParseState Kind

30−parseRow = const Row <$> lexeme (P.char '#')

30+parseBang = const Bang <$> lexeme (P.char '!')

31

32parseTypeAtom :: P.Parsec String ParseState Kind

33parseTypeAtom = indented *> P.choice (map P.try

34 [ parseStar

35− , parseRow

35+ , parseBang

36 , parens parseKind ])

37

38parseKind :: P.Parsec String ParseState Kind

39parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"

40 where

41+ operators = [ [ P.Prefix (lexeme (P.char '#') >> return Row) ]

41− operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]

42+ , [ P.Infix (lexeme (P.try (P.string "->")) >> return FunKind) P.AssocRight ] ]

src/Language/PureScript/Parser/Types.hs+4−3

@@ -69,6 +69,7 @@ parseTypeAtom = indented *> P.choice (map P.try

69 , parseTypeVariable

70 , parseTypeConstructor

71 , parseForAll

72+ , parens parseRow

72 , parens parseType ])

73 , parens parseType ])

73

74

74parseAnyType :: P.Parsec String ParseState Type

75parseAnyType :: P.Parsec String ParseState Type

@@ -90,14 +91,14 @@ parsePolyType = do

90 unless (isPolyType ty) $ P.unexpected "polymorphic type"

91 unless (isPolyType ty) $ P.unexpected "polymorphic type"

91 return ty

92 return ty

92

93

93−parseNameAndType :: P.Parsec String ParseState (String, Type)

94+parseNameAndType :: P.Parsec String ParseState t -> P.Parsec String ParseState (String, t)

94−parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parsePolyType

95+parseNameAndType p = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> p

95

96

96parseRowEnding :: P.Parsec String ParseState Type

97parseRowEnding :: P.Parsec String ParseState Type

97parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))

98parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))

98

99

99parseRow :: P.Parsec String ParseState Type

100parseRow :: P.Parsec String ParseState Type

100−parseRow = (fromList <$> (commaSep parseNameAndType) <*> parseRowEnding) P.<?> "row"

101+parseRow = (fromList <$> (commaSep $ parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"

101 where

102 where

102 fromList :: [(String, Type)] -> Type -> Type

103 fromList :: [(String, Type)] -> Type -> Type

103 fromList [] r = r

104 fromList [] r = r

src/Language/PureScript/Pretty/Kinds.hs+9−2

@@ -27,10 +27,16 @@ typeLiterals :: Pattern () Kind String

27typeLiterals = mkPattern match

28 where

29 match Star = Just "*"

30− match Row = Just "#"

30+ match Bang = Just "!"

31 match (KUnknown (Unknown u)) = Just $ 'u' : show u

32 match _ = Nothing

33

34+matchRow :: Pattern () Kind ((), Kind)

35+matchRow = mkPattern match

36+ where

37+ match (Row k) = Just ((), k)

38+ match _ = Nothing

39+

34funKind :: Pattern () Kind (Kind, Kind)

40funKind :: Pattern () Kind (Kind, Kind)

35funKind = mkPattern match

41funKind = mkPattern match

36 where

42 where

@@ -44,4 +50,5 @@ prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

44 matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

50 matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)

45 operators :: OperatorTable () Kind String

51 operators :: OperatorTable () Kind String

46 operators =

52 operators =

53+ OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]

47− OperatorTable [ [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]

54+ , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]

src/Language/PureScript/Pretty/Types.hs+3−1

@@ -32,13 +32,15 @@ typeLiterals = mkPattern match

32 match String = Just "String"

33 match Boolean = Just "Boolean"

34 match (Array ty) = Just $ "[" ++ prettyPrintType ty ++ "]"

35− match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"

35+ match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }"

36 match (TypeVar var) = Just var

37 match (TypeConstructor ctor) = Just $ show ctor

38 match (TUnknown (Unknown u)) = Just $ 'u' : show u

39 match (Skolem s) = Just $ 's' : show s

40 match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintType args) ++ ">"

41 match (ForAll ident ty) = Just $ "forall " ++ ident ++ ". " ++ prettyPrintType ty

42+ match REmpty = Just $ prettyPrintRow REmpty

43+ match row@(RCons _ _ _) = Just $ prettyPrintRow row

42 match _ = Nothing

44 match _ = Nothing

43

45

44prettyPrintRow :: Type -> String

46prettyPrintRow :: Type -> String

src/Language/PureScript/TypeChecker/Kinds.hs+8−6

@@ -44,7 +44,8 @@ instance Unifiable Kind where

44 KUnknown u ~~ k = replace u k

45 k ~~ KUnknown u = replace u k

46 Star ~~ Star = return ()

47− Row ~~ Row = return ()

47+ Bang ~~ Bang = return ()

48+ Row k1 ~~ Row k2 = k1 ~~ k2

48 FunKind k1 k2 ~~ FunKind k3 k4 = do

49 FunKind k1 k2 ~~ FunKind k3 k4 = do

49 k1 ~~ k3

50 k1 ~~ k3

50 k2 ~~ k4

51 k2 ~~ k4

@@ -100,7 +101,7 @@ infer (Array t) = do

100 return Star

101 return Star

101infer (Object row) = do

102infer (Object row) = do

102 k <- infer row

103 k <- infer row

103− k ~~ Row

104+ k ~~ Row Star

104 return Star

105 return Star

105infer (Function args ret) = do

106infer (Function args ret) = do

106 ks <- mapM infer args

107 ks <- mapM infer args

@@ -127,11 +128,12 @@ infer (ForAll ident ty) = do

127 k <- fresh

128 k <- fresh

128 moduleName <- substCurrentModule <$> ask

129 moduleName <- substCurrentModule <$> ask

129 bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty

130 bindLocalTypeVariables moduleName [(ProperName ident, k)] $ infer ty

130−infer REmpty = return Row

131+infer REmpty = do

132+ k <- fresh

133+ return $ Row k

131infer (RCons _ ty row) = do

134infer (RCons _ ty row) = do

132 k1 <- infer ty

135 k1 <- infer ty

133 k2 <- infer row

136 k2 <- infer row

134− k1 ~~ Star

135− k2 ~~ Row

137+ k2 ~~ Row k1

136− return Row

138+ return $ Row k1

137infer _ = error "Invalid argument to infer"

139infer _ = error "Invalid argument to infer"

src/Language/PureScript/TypeChecker/Types.hs+1−1

@@ -24,7 +24,7 @@ import Data.Maybe (fromMaybe)

24import Data.Either (lefts, rights)

25import qualified Data.Data as D

26import Data.Generics

27− (mkT, something, everywhere, everywhereBut, mkQ, extQ)

27+ (mkT, something, everywhere, everywhereBut, mkQ)

28

29import Language.PureScript.Values

30import Language.PureScript.Types