d66e332 · rowtype-yoga/purescript-native

PureScript.cabal+11−14

@@ -15,19 +15,19 @@ data-dir: ""

1515library

1616 build-depends: base -any, syb -any, cmdtheline -any,

1717 containers -any, mtl -any, parsec -any, utf8-string -any

18− exposed-modules: PureScript

18+ exposed-modules: PureScript PureScript.Declarations PureScript.Names PureScript.TypeChecker.Synonyms

19+ PureScript.CodeGen.Externs PureScript.CodeGen.JS

20+ PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main

21+ PureScript.CodeGen PureScript.Kinds PureScript.Parser

22+ PureScript.TypeChecker PureScript.Types PureScript.Values

23+ PureScript.Parser.Common PureScript.Parser.Declarations

24+ PureScript.Parser.Types PureScript.Parser.Values

25+ PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad

26+ PureScript.TypeChecker.Types

1927 exposed: True

2028 buildable: True

2129 hs-source-dirs: src

22− other-modules: PureScript.Names PureScript.TypeChecker.Synonyms

23− PureScript.CodeGen.Externs PureScript.CodeGen.JS

24− PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main

25− PureScript.CodeGen PureScript.Kinds PureScript.Parser

26− PureScript.TypeChecker PureScript.Types PureScript.Values

27− PureScript.Parser.Common PureScript.Parser.Declarations

28− PureScript.Parser.Types PureScript.Parser.Values

29− PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad

30− PureScript.TypeChecker.Types

30+ other-modules:

3131

3232executable psc

3333 build-depends: base -any, cmdtheline -any, containers -any,

@@ -35,7 +35,4 @@ executable psc

3535 main-is: Main.hs

3636 buildable: True

3737 hs-source-dirs: src

38− other-modules: PureScript.Names PureScript.TypeChecker.Synonyms

39− PureScript.CodeGen.Externs PureScript.CodeGen.JS

40− PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common

41−

38+ other-modules:

examples/ReadShow.ps+2−2

@@ -1,5 +1,5 @@

1−extern read :: forall a. (String) -> a

1+extern read :: forall a. String -> a

22

3−extern show :: forall a. (a) -> String

3+extern show :: forall a. a -> String

44

55test = \x -> show(read(x))

examples/TypeSynonyms.ps+3−3

@@ -1,9 +1,9 @@

11type Lens a b =

2− { get :: (a) -> b

3− ; set :: (a) -> (b) -> b

2+ { get :: a -> b

3+ ; set :: a -> b -> b

44 }

55

6−composeLenses :: forall a b c. (Lens a b) -> (Lens b c) -> Lens a c

6+composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c

77composeLenses = \l1 -> \l2 ->

88 { get: \a -> l2.get(l1.get(a))

99 , set: \a -> \c -> do

src/Main.hs+1−1

@@ -45,7 +45,7 @@ compile inputFiles outputFile externsFile = do

4545 Nothing -> U.putStrLn js

4646 case externsFile of

4747 Nothing -> return ()

48− Just filePath -> U.writeFile filePath $ intercalate "\n" $ map (uncurry externToPs) $ M.toList $ names env

48+ Just filePath -> U.writeFile filePath $ intercalate "\n" $ mapMaybe (externToPs env) decls

4949 exitSuccess

5050

5151inputFiles :: Term [FilePath]

src/PureScript.hs+2

@@ -17,6 +17,7 @@ module PureScript (

1717 module PureScript.Types,

1818 module PureScript.Kinds,

1919 module PureScript.Declarations,

20+ module PureScript.Names,

2021 module PureScript.Parser,

2122 module PureScript.CodeGen,

2223 module PureScript.TypeChecker

@@ -26,6 +27,7 @@ import PureScript.Values

2627import PureScript.Types

2728import PureScript.Kinds

2829import PureScript.Declarations

30+import PureScript.Names

2931import PureScript.Parser

3032import PureScript.CodeGen

3133import PureScript.TypeChecker

src/PureScript/CodeGen/Common.hs+12−3

@@ -16,6 +16,7 @@

1616

1717module PureScript.CodeGen.Common where

1818

19+import Data.Char

1920import Data.Maybe (fromMaybe)

2021import Data.List (nub, intersperse, intercalate)

2122import Data.Function (fix)

@@ -26,10 +27,18 @@ import Control.Category ((>>>))

2627import qualified Control.Arrow as A

2728import Control.Arrow ((***))

2829

30+import PureScript.Names

2931import PureScript.Values

3032import PureScript.Types

3133import PureScript.Declarations

3234

35+identToJs :: Ident -> String

36+identToJs (Ident name) = name

37+identToJs (Op op) = concatMap opCharToString op

38+ where

39+ opCharToString :: Char -> String

40+ opCharToString = (:) '$'. show . ord

41+

3342newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow)

3443

3544pattern :: Pattern a b -> a -> Maybe b

@@ -61,7 +70,7 @@ wrap split f p = fix $ \c -> (split >>> (C.id *** c) >>> A.arr (uncurry f)) <|>

6170split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r

6271split s f p = (s >>> A.arr (uncurry f)) <|> p

6372

64−data OperatorTable a r = OperatorTable { runOperatorTable :: [Operator a r] }

73+data OperatorTable a r = OperatorTable { runOperatorTable :: [ [Operator a r] ] }

6574

6675data Operator a r where

6776 AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r

@@ -70,10 +79,10 @@ data Operator a r where

7079 Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r

7180

7281buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r

73−buildPrettyPrinter table p = foldl (\p' op ->

82+buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<|>) (flip map ops $ \op ->

7483 case op of

7584 AssocL pat g -> chainl pat g p'

7685 AssocR pat g -> chainr pat g p'

7786 Wrap pat g -> wrap pat g p'

7887 Split pat g -> split pat g p'

79− ) p $ runOperatorTable table

88+ )) p $ runOperatorTable table

src/PureScript/CodeGen/Externs.hs+14−5

@@ -21,6 +21,7 @@ module PureScript.CodeGen.Externs (

2121import Data.Maybe (fromMaybe)

2222import Data.List (intersperse, intercalate)

2323import qualified Control.Arrow as A

24+import qualified Data.Map as M

2425import Control.Applicative

2526

2627import PureScript.Values

@@ -30,8 +31,15 @@ import PureScript.Declarations

3031import PureScript.TypeChecker.Monad

3132import PureScript.CodeGen.Common

3233

33−externToPs :: Ident -> (PolyType, NameKind) -> String

34−externToPs name (ty, _) = "extern " ++ show name ++ " :: " ++ polyTypeToPs ty

34+externToPs :: Environment -> Declaration -> Maybe String

35+externToPs env (ValueDeclaration name _) = do

36+ (ty, _) <- M.lookup name $ names env

37+ return $ "extern " ++ show name ++ " :: " ++ polyTypeToPs ty

38+externToPs env (ExternDeclaration name ty) =

39+ return $ "extern " ++ show name ++ " :: " ++ polyTypeToPs ty

40+externToPs env (TypeSynonymDeclaration name args ty) =

41+ return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ typeToPs ty

42+externToPs _ _ = Nothing

3543

3644typeLiterals :: Pattern Type String

3745typeLiterals = Pattern $ A.Kleisli match

@@ -85,9 +93,10 @@ typeToPs = fromMaybe (error "Incomplete pattern") . pattern matchType

8593 matchType = buildPrettyPrinter operators (typeLiterals <|> fmap parens matchType)

8694 operators :: OperatorTable Type String

8795 operators =

88− OperatorTable $ [ AssocL typeApp $ \f x -> f ++ " " ++ x

89− , Split function $ \args ret -> "(" ++ intercalate ", " (map typeToPs args) ++ ") -> " ++ typeToPs ret

90− , AssocL singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret

96+ OperatorTable $ [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]

97+ , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret

98+ , Split function $ \args ret -> "(" ++ intercalate ", " (map typeToPs args) ++ ") -> " ++ typeToPs ret

99+ ]

91100 ]

92101

93102polyTypeToPs :: PolyType -> String

src/PureScript/CodeGen/JS.hs+27−34

@@ -29,13 +29,6 @@ import PureScript.Declarations

2929import PureScript.CodeGen.Common

3030import PureScript.CodeGen.Common.Gen

3131

32−identToJs :: Ident -> String

33−identToJs (Ident name) = name

34−identToJs (Op op) = concatMap opCharToString op

35− where

36− opCharToString :: Char -> String

37− opCharToString = (:) '$'. show . ord

38−

3932declToJs :: Declaration -> Maybe String

4033declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"

4134declToJs (DataDeclaration _ _ ctors) =

@@ -117,33 +110,33 @@ valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue

117110 matchValue = buildPrettyPrinter operators (literals <|> fmap parens matchValue)

118111 operators :: OperatorTable Value String

119112 operators =

120− OperatorTable $ [ Wrap accessor $ \prop val -> val ++ "." ++ prop

121− , Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]"

122− , Wrap app $ \args val -> val ++ "(" ++ args ++ ")"

123− , Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }"

124− , binary LessThan "<"

125− , binary LessThanOrEqualTo "<="

126− , binary GreaterThan ">"

127− , binary GreaterThanOrEqualTo ">="

128− , unary Not "!"

129− , unary BitwiseNot "~"

130− , unary Negate "-"

131− , binary Multiply "*"

132− , binary Divide "/"

133− , binary Modulus "%"

134− , binary Concat "++"

135− , binary Add "+"

136− , binary Subtract "-"

137− , binary ShiftLeft "<<"

138− , binary ShiftRight ">>"

139− , binary ZeroFillShiftRight ">>>"

140− , binary EqualTo "==="

141− , binary NotEqualTo "!=="

142− , binary BitwiseAnd "&"

143− , binary BitwiseXor "^"

144− , binary BitwiseOr "|"

145− , binary And "&&"

146− , binary Or "||"

113+ OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

114+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

115+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

116+ , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ]

117+ , [ binary LessThan "<" ]

118+ , [ binary LessThanOrEqualTo "<=" ]

119+ , [ binary GreaterThan ">" ]

120+ , [ binary GreaterThanOrEqualTo ">=" ]

121+ , [ unary Not "!" ]

122+ , [ unary BitwiseNot "~" ]

123+ , [ unary Negate "-" ]

124+ , [ binary Multiply "*" ]

125+ , [ binary Divide "/" ]

126+ , [ binary Modulus "%" ]

127+ , [ binary Concat "++" ]

128+ , [ binary Add "+" ]

129+ , [ binary Subtract "-" ]

130+ , [ binary ShiftLeft "<<" ]

131+ , [ binary ShiftRight ">>" ]

132+ , [ binary ZeroFillShiftRight ">>>" ]

133+ , [ binary EqualTo "===" ]

134+ , [ binary NotEqualTo "!==" ]

135+ , [ binary BitwiseAnd "&" ]

136+ , [ binary BitwiseXor "^" ]

137+ , [ binary BitwiseOr "|" ]

138+ , [ binary And "&&" ]

139+ , [ binary Or "||" ]

147140 ]

148141

149142unaryOperatorString :: UnaryOperator -> String

src/PureScript/Parser/Common.hs+4−1

@@ -62,7 +62,10 @@ reservedNames = [ "case"

6262 , "try"

6363 , "typeof"

6464 , "void"

65− , "with" ]

65+ , "with"

66+ , "Number"

67+ , "String"

68+ , "Boolean" ]

6669

6770reservedOpNames :: [String]

6871reservedOpNames = [ "!", "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>"

src/PureScript/Parser/Types.hs+5−5

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

2626import Control.Arrow (Arrow(..))

2727

2828parseNumber :: P.Parsec String P.Column Type

29−parseNumber = const Number <$> P.string "Number"

29+parseNumber = const Number <$> reserved "Number"

3030

3131parseString :: P.Parsec String P.Column Type

32−parseString = const String <$> P.string "String"

32+parseString = const String <$> reserved "String"

3333

3434parseBoolean :: P.Parsec String P.Column Type

35−parseBoolean = const Boolean <$> P.string "Boolean"

35+parseBoolean = const Boolean <$> reserved "Boolean"

3636

3737parseArray :: P.Parsec String P.Column Type

3838parseArray = squares $ Array <$> parseType

@@ -73,8 +73,8 @@ parseType :: P.Parsec String P.Column Type

7373parseType = P.buildExpressionParser operators . buildPostfixParser postfixTable $ parseTypeAtom

7474 where

7575 postfixTable :: [P.Parsec String P.Column (Type -> Type)]

76− postfixTable = [ flip TypeApp <$> parseTypeAtom ]

77− operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocLeft ] ]

76+ postfixTable = [ flip TypeApp <$> (indented *> parseTypeAtom) ]

77+ operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ]

7878

7979parseNameAndType :: P.Parsec String P.Column (String, Type)

8080parseNameAndType = (,) <$> (indented *> identifier <* indented <* lexeme (P.string "::")) <*> parseType