5c3b65d · rowtype-yoga/purescript-native

README.md+3−1

compare with golang

unifiedsplit

@@ -5,11 +5,14 @@ A small strongly, statically typed compile-to-JS language with basic extensible

5

6## Current Features

7

8+- Full Type Inference

9+- Higher Kinded Polymorphism

8- Support for basic Javascript types

10- Support for basic Javascript types

9- Extensible records

11- Extensible records

10- Type-safe blocks with for/while/assignment etc.

12- Type-safe blocks with for/while/assignment etc.

11- Functions with multiple arguments

13- Functions with multiple arguments

12- Pattern matching

14- Pattern matching

15+- Simple FFI

13

16

14## TODO

17## TODO

15

18

@@ -18,7 +21,6 @@ A small strongly, statically typed compile-to-JS language with basic extensible

18- User defined operators

21- User defined operators

19- Mutually recursive functions

22- Mutually recursive functions

20- Modules

23- Modules

21−- FFI

22- Top level pattern matching

24- Top level pattern matching

23- Guards

25- Guards

24- Type classes

26- Type classes

examples/FFI.psnew file+5

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

1+extern foo :: (String) -> String

2+

3+bar :: (String) -> String

4+

5+bar = \x -> foo(x ++ "bar")

examples/List.ps+1−1

@@ -3,7 +3,7 @@ data List a

3 | Cons

4 { head :: a

5 ; tail :: List a

6− ; {} }

6+ }

7

8null = \l -> case l of

9 { Nil -> true

src/Main.hs+12−4

@@ -21,9 +21,10 @@ import System.Console.CmdTheLine

21import Control.Applicative

22import System.Exit (exitSuccess, exitFailure)

23import qualified System.IO.UTF8 as U

24+import qualified Data.Map as M

24

25

25−compile :: [FilePath] -> Maybe FilePath -> IO ()

26+compile :: [FilePath] -> Maybe FilePath -> Maybe FilePath -> IO ()

26−compile inputFiles outputFile = do

27+compile inputFiles outputFile externsFile = do

27 input <- fmap concat $ mapM U.readFile inputFiles

28 input <- fmap concat $ mapM U.readFile inputFiles

28 let ast = parseDeclarations input

29 let ast = parseDeclarations input

29 case ast of

30 case ast of

@@ -35,11 +36,14 @@ compile inputFiles outputFile = do

35 Left typeError -> do

36 Left typeError -> do

36 U.putStrLn typeError

37 U.putStrLn typeError

37 exitFailure

38 exitFailure

38− Right _ -> do

39+ Right (_, env) -> do

39 let js = intercalate "\n" $ mapMaybe declToJs decls

40 let js = intercalate "\n" $ mapMaybe declToJs decls

40 case outputFile of

41 case outputFile of

41 Just path -> U.writeFile path js

42 Just path -> U.writeFile path js

42 Nothing -> U.putStrLn js

43 Nothing -> U.putStrLn js

44+ case externsFile of

45+ Nothing -> return ()

46+ Just filePath -> U.writeFile filePath $ intercalate "\n\n" $ map externToJs $ M.toList $ names env

43 exitSuccess

47 exitSuccess

44

48

45inputFiles :: Term [FilePath]

49inputFiles :: Term [FilePath]

@@ -50,8 +54,12 @@ outputFile :: Term (Maybe FilePath)

50outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])

54outputFile = value $ opt Nothing $ (optInfo [ "o", "output" ])

51 { optDoc = "The output .js file" }

55 { optDoc = "The output .js file" }

52

56

57+externsFile :: Term (Maybe FilePath)

58+externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])

59+ { optDoc = "The output .e.ps file" }

60+

53term :: Term (IO ())

61term :: Term (IO ())

54−term = compile <$> inputFiles <*> outputFile

62+term = compile <$> inputFiles <*> outputFile <*> externsFile

55

63

56termInfo :: TermInfo

64termInfo :: TermInfo

57termInfo = defTI

65termInfo = defTI

src/PureScript/CodeGen.hs+55−1

@@ -15,7 +15,8 @@

15{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}

16

17module PureScript.CodeGen (

18− declToJs

18+ declToJs,

19+ externToJs

19) where

20) where

20

21

21import Data.Maybe (fromMaybe)

22import Data.Maybe (fromMaybe)

@@ -29,6 +30,7 @@ import qualified Control.Arrow as A

29import Control.Arrow ((***))

30import Control.Arrow ((***))

30

31

31import PureScript.Values

32import PureScript.Values

33+import PureScript.Types

32import PureScript.Declarations

34import PureScript.Declarations

33

35

34-- First Order Patterns

36-- First Order Patterns

@@ -299,3 +301,55 @@ assignmentTargetToJs :: AssignmentTarget -> String

299assignmentTargetToJs (AssignVariable var) = var

301assignmentTargetToJs (AssignVariable var) = var

300assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"

302assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"

301assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop

303assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop

304+

305+-- Externs

306+

307+typeLiterals :: Pattern Type String

308+typeLiterals = Pattern $ A.Kleisli match

309+ where

310+ match Number = Just "Number"

311+ match String = Just "String"

312+ match Boolean = Just "Boolean"

313+ match (Array ty) = Just $ "[" ++ typeToPs ty ++ "]"

314+ match (Object row) = Just $ "{ " ++ rowToPs row ++ " }"

315+ match (TypeVar var) = Just var

316+ match (TypeConstructor ctor) = Just ctor

317+ match _ = Nothing

318+

319+rowToPs :: Row -> String

320+rowToPs = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList

321+ where

322+ nameAndTypeToPs :: String -> Type -> String

323+ nameAndTypeToPs name ty = name ++ " :: " ++ typeToPs ty

324+ tailToPs :: Row -> String

325+ tailToPs REmpty = ""

326+ tailToPs (RowVar var) = "| " ++ var

327+ toList :: Row -> ([(String, Type)], Row)

328+ toList (RCons name ty row) = let (tys, rest) = toList row

329+ in ((name, ty):tys, rest)

330+ toList r = ([], r)

331+

332+typeApp :: Pattern Type (Type, Type)

333+typeApp = Pattern $ A.Kleisli match

334+ where

335+ match (TypeApp f x) = Just (f, x)

336+ match _ = Nothing

337+

338+function :: Pattern Type ([Type], Type)

339+function = Pattern $ A.Kleisli match

340+ where

341+ match (Function args ret) = Just (args, ret)

342+ match _ = Nothing

343+

344+typeToPs :: Type -> String

345+typeToPs = fromMaybe (error "Incomplete pattern") . pattern matchType

346+ where

347+ matchType :: Pattern Type String

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

349+ operators :: OperatorTable Type String

350+ operators =

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

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

353+

354+externToJs :: (String, Type) -> String

355+externToJs (name, ty) = "extern " ++ name ++ " :: " ++ typeToPs ty

src/PureScript/Declarations.hs+2−1

@@ -23,7 +23,8 @@ import PureScript.Types

23data Declaration

24 = DataDeclaration DataConstructors

25 | TypeDeclaration String Type

26− | ValueDeclaration String Value deriving Show

26+ | ValueDeclaration String Value

27+ | ExternDeclaration String Type deriving Show

27

28

28data DataConstructors = DataConstructors

29data DataConstructors = DataConstructors

29 { typeConstructorName :: String

30 { typeConstructorName :: String

src/PureScript/Kinds.hs+1−7

@@ -20,10 +20,4 @@ data Kind

20 = KUnknown Int

21 | Star

22 | Row

23− | FunKind Kind Kind deriving Eq

23+ | FunKind Kind Kind deriving (Show, Eq)

24−

25−instance Show Kind where

26− show (KUnknown _) = "?"

27− show Star = "*"

28− show Row = "R"

29− show (FunKind k1 k2) = "(" ++ show k1 ++ ") -> (" ++ show k2 ++ ")"

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

@@ -31,7 +31,8 @@ langDef = PL.haskellStyle

31 , "else"

32 , "return"

33 , "true"

34− , "false" ]

34+ , "false"

35+ , "extern" ]

35 }

36 }

36

37

37tokenParser = PT.makeTokenParser langDef

38tokenParser = PT.makeTokenParser langDef

src/PureScript/Parser/Declarations.hs+11−2

@@ -40,12 +40,21 @@ parseDataDeclaration = do

40 ctors <- P.sepBy1 ((,) <$> properName <*> P.optionMaybe parseType) (lexeme $ P.char '|')

41 return $ DataDeclaration $ DataConstructors name tyArgs ctors

42

43+parseTypeDeclaration :: P.Parsec String () Declaration

44+parseTypeDeclaration = TypeDeclaration <$> identifier <*> (lexeme (P.string "::") *> parseType)

45+

43parseValueDeclaration :: P.Parsec String () Declaration

46parseValueDeclaration :: P.Parsec String () Declaration

44parseValueDeclaration = ValueDeclaration <$> identifier <*> (lexeme (P.char '=') *> parseValue)

47parseValueDeclaration = ValueDeclaration <$> identifier <*> (lexeme (P.char '=') *> parseValue)

45

48

49+parseExternDeclaration :: P.Parsec String () Declaration

50+parseExternDeclaration = ExternDeclaration <$> (reserved "extern" *> (identifier <|> properName)) <*> (lexeme (P.string "::") *> parseType)

51+

46parseDeclaration :: P.Parsec String () Declaration

52parseDeclaration :: P.Parsec String () Declaration

53+parseDeclaration = P.choice $ map P.try

47−parseDeclaration = parseDataDeclaration

54+ [ parseDataDeclaration

55+ , parseTypeDeclaration

48− P.<|> parseValueDeclaration

56+ , parseValueDeclaration

57+ , parseExternDeclaration ]

49

58

50parseDeclarations :: String -> Either P.ParseError [Declaration]

59parseDeclarations :: String -> Either P.ParseError [Declaration]

51parseDeclarations = mapM (P.parse (parseDeclaration <* whiteSpace <* P.eof) "Declaration") . splitFileIntoDeclarations

60parseDeclarations = mapM (P.parse (parseDeclaration <* whiteSpace <* P.eof) "Declaration") . splitFileIntoDeclarations

src/PureScript/Parser/Types.hs+9−13

@@ -66,19 +66,15 @@ parseTypeAtom = P.choice $ map P.try

66parseType :: P.Parsec String () Type

67parseType = fold (lexeme parseTypeAtom) (lexeme parseTypeAtom) TypeApp

68

69−parseREmpty :: P.Parsec String () Row

69+parseNameAndType :: P.Parsec String () (String, Type)

70−parseREmpty = braces whiteSpace >> return REmpty

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

71

72−parseRCons :: P.Parsec String () Row

72+parseRowEnding :: P.Parsec String () Row

73−parseRCons = RCons <$> (identifier <* lexeme (P.string "::"))

73+parseRowEnding = P.option REmpty (RowVar <$> (lexeme (P.char '|') *> identifier))

74− <*> (parseType <* semi)

75− <*> parseRow

76−

77−parseRowVariable :: P.Parsec String () Row

78−parseRowVariable = RowVar <$> identifier

79

74

80parseRow :: P.Parsec String () Row

75parseRow :: P.Parsec String () Row

81−parseRow = P.choice $ map P.try

76+parseRow = fromList <$> semiSep parseNameAndType <*> parseRowEnding

82− [ parseRCons

77+ where

83− , parseRowVariable

78+ fromList :: [(String, Type)] -> Row -> Row

84− , parseREmpty ]

79+ fromList [] r = r

80+ fromList ((name, t):ts) r = RCons name t (fromList ts r)

src/PureScript/TypeChecker.hs+36−25

@@ -18,7 +18,6 @@ module PureScript.TypeChecker (

18 module PureScript.TypeChecker.Monad,

19 module PureScript.TypeChecker.Kinds,

20 module PureScript.TypeChecker.Types,

21− typeCheck,

22 typeCheckAll,

21 typeCheckAll,

23) where

22) where

24

23

@@ -40,30 +39,42 @@ import Control.Monad.Error

40

39

41import qualified Data.Map as M

40import qualified Data.Map as M

42

41

43−typeCheck :: Declaration -> Check ()

42+typeCheckAll :: [Declaration] -> Check ()

43+typeCheckAll [] = return ()

44−typeCheck (DataDeclaration dcs@(DataConstructors

44+typeCheckAll (DataDeclaration dcs@(DataConstructors

45 { typeConstructorName = name

46 , typeArguments = args

47 , dataConstructors = ctors

48+ }) : rest) = do

48− })) = rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do

49+ rethrow (("Error in type constructor " ++ name ++ ": ") ++) $ do

49− env <- getEnv

50+ env <- getEnv

50− guardWith (name ++ " is already defined") $ not $ M.member name (types env)

51+ guardWith (name ++ " is already defined") $ not $ M.member name (types env)

51− ctorKind <- kindsOf name args (catMaybes $ map snd ctors)

52+ ctorKind <- kindsOf name args (catMaybes $ map snd ctors)

52− putEnv $ env { types = M.insert name ctorKind (types env) }

53+ putEnv $ env { types = M.insert name ctorKind (types env) }

53− flip mapM_ ctors $ \(dctor, maybeTy) ->

54+ flip mapM_ ctors $ \(dctor, maybeTy) ->

54− rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do

55+ rethrow (("Error in data constructor " ++ name ++ ": ") ++) $ do

55− env' <- getEnv

56+ env' <- getEnv

56− guardWith (dctor ++ " is already defined") $ not $ flip M.member (names env') dctor

57+ guardWith (dctor ++ " is already defined") $ not $ flip M.member (names env') dctor

57− let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)

58+ let retTy = foldl TypeApp (TypeConstructor name) (map TypeVar args)

58− let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

59+ let dctorTy = maybe retTy (\ty -> Function [ty] retTy) maybeTy

59− putEnv $ env' { names = M.insert dctor dctorTy (names env') }

60+ putEnv $ env' { names = M.insert dctor dctorTy (names env') }

61+ typeCheckAll rest

62+typeCheckAll (TypeDeclaration name ty : ValueDeclaration name' val : rest) | name == name' =

63+ typeCheckAll (ValueDeclaration name (TypedValue val ty) : rest)

64+typeCheckAll (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ name

65+typeCheckAll (ValueDeclaration name val : rest) = do

60−typeCheck (ValueDeclaration name val) = rethrow (("Error in declaration " ++ name ++ ": ") ++) $ do

66+ rethrow (("Error in declaration " ++ name ++ ": ") ++) $ do

61− env <- getEnv

67+ env <- getEnv

62− case M.lookup name (names env) of

68+ case M.lookup name (names env) of

63− Just ty -> throwError $ name ++ " is already defined"

69+ Just ty -> throwError $ name ++ " is already defined"

64− Nothing -> do

70+ Nothing -> do

65− ty <- typeOf name val

71+ ty <- typeOf name val

66− putEnv (env { names = M.insert name ty (names env) })

72+ putEnv (env { names = M.insert name ty (names env) })

67−

73+ typeCheckAll rest

68−typeCheckAll :: [Declaration] -> Check ()

74+typeCheckAll (ExternDeclaration name ty : rest) = do

69−typeCheckAll = mapM_ typeCheck

75+ rethrow (("Error in extern declaration " ++ name ++ ": ") ++) $ do

76+ env <- getEnv

77+ case M.lookup name (names env) of

78+ Just _ -> throwError $ name ++ " is already defined"

79+ Nothing -> putEnv (env { names = M.insert name ty (names env) })

80+ typeCheckAll rest

src/PureScript/Types.hs+2−20

@@ -31,28 +31,10 @@ data Type

31 | Function [Type] Type

32 | TypeVar String

33 | TypeConstructor String

34− | TypeApp Type Type

34+ | TypeApp Type Type deriving Show

35

36data Row

37 = RUnknown Int

38 | RowVar String

39 | REmpty

40− | RCons String Type Row

40+ | RCons String Type Row deriving Show

41−

42−instance Show Type where

43− show (TUnknown _) = "?"

44− show Number = "Number"

45− show String = "String"

46− show Boolean = "Boolean"

47− show (Array t) = "[" ++ show t ++ "]"

48− show (Object row) = "{ " ++ show row ++ " }"

49− show (Function args ret) = "(" ++ intercalate ", " (map show args) ++ ") -> " ++ show ret

50− show (TypeVar v) = v

51− show (TypeConstructor c) = c

52− show (TypeApp t1 t2) = "(" ++ show t1 ++ ") (" ++ show t2 ++ ")"

53−

54−instance Show Row where

55− show (RUnknown _) = "?"

56− show REmpty = "{}"

57− show (RowVar v) = v

58− show (RCons name ty row) = name ++ " :: " ++ show ty ++ "; " ++ show row