5c3b65d · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

FFI

commit5c3b65dc8dfaaba67b2b77633901a9c0a7bb7576 authorPhil Freeman <paf31@cantab.net> dateFri 4 Oct 2013, 19:48 (13 years ago) parentadc70ed

12 files changed+139−76

compare with golang

unifiedsplit

README.md+3−1 examples/FFI.ps+5 examples/List.ps+1−1 src/Main.hs+12−4 src/PureScript/CodeGen.hs+55−1 src/PureScript/Declarations.hs+2−1 src/PureScript/Kinds.hs+1−7 src/PureScript/Parser/Common.hs+2−1 src/PureScript/Parser/Declarations.hs+11−2 src/PureScript/Parser/Types.hs+9−13 src/PureScript/TypeChecker.hs+36−25 src/PureScript/Types.hs+2−20

README.md+3−1

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

66## Current Features

8+- Full Type Inference

9+- Higher Kinded Polymorphism

810- Support for basic Javascript types

911- Extensible records

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

1113- Functions with multiple arguments

1214- Pattern matching

15+- Simple FFI

1316

1417## TODO

1518

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

1821- User defined operators

1922- Mutually recursive functions

2023- Modules

21−- FFI

2224- Top level pattern matching

2325- Guards

2426- Type classes

examples/FFI.psnew file+5

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

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

3+bar :: (String) -> String

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

examples/List.ps+1−1

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

33 | Cons

44 { head :: a

55 ; tail :: List a

6− ; {} }

6+ }

88null = \l -> case l of

99 { Nil -> true

src/Main.hs+12−4

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

2121import Control.Applicative

2222import System.Exit (exitSuccess, exitFailure)

2323import qualified System.IO.UTF8 as U

24+import qualified Data.Map as M

2425

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

26−compile inputFiles outputFile = do

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

27+compile inputFiles outputFile externsFile = do

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

2829 let ast = parseDeclarations input

2930 case ast of

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

3536 Left typeError -> do

3637 U.putStrLn typeError

3738 exitFailure

38− Right _ -> do

39+ Right (_, env) -> do

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

4041 case outputFile of

4142 Just path -> U.writeFile path js

4243 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

4347 exitSuccess

4448

4549inputFiles :: Term [FilePath]

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

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

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

5256

57+externsFile :: Term (Maybe FilePath)

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

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

60+

5361term :: Term (IO ())

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

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

5563

5664termInfo :: TermInfo

5765termInfo = defTI

src/PureScript/CodeGen.hs+55−1

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

1515{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}

1616

1717module PureScript.CodeGen (

18− declToJs

18+ declToJs,

19+ externToJs

1920) where

2021

2122import Data.Maybe (fromMaybe)

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

2930import Control.Arrow ((***))

3031

3132import PureScript.Values

33+import PureScript.Types

3234import PureScript.Declarations

3335

3436-- First Order Patterns

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

299301assignmentTargetToJs (AssignVariable var) = var

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

301303assignmentTargetToJs (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

2323data Declaration

2424 = DataDeclaration DataConstructors

2525 | TypeDeclaration String Type

26− | ValueDeclaration String Value deriving Show

26+ | ValueDeclaration String Value

27+ | ExternDeclaration String Type deriving Show

2728

2829data DataConstructors = DataConstructors

2930 { typeConstructorName :: String

src/PureScript/Kinds.hs+1−7

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

2020 = KUnknown Int

2121 | Star

2222 | Row

23− | FunKind Kind Kind deriving 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 ++ ")"

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

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

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

3131 , "else"

3232 , "return"

3333 , "true"

34− , "false" ]

34+ , "false"

35+ , "extern" ]

3536 }

3637

3738tokenParser = PT.makeTokenParser langDef

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

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

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

4141 return $ DataDeclaration $ DataConstructors name tyArgs ctors

4242

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

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

45+

4346parseValueDeclaration :: P.Parsec String () Declaration

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

4548

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

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

51+

4652parseDeclaration :: P.Parsec String () Declaration

47−parseDeclaration = parseDataDeclaration

48− P.<|> parseValueDeclaration

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

54+ [ parseDataDeclaration

55+ , parseTypeDeclaration

56+ , parseValueDeclaration

57+ , parseExternDeclaration ]

4958

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

5160parseDeclarations = 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

6666parseType :: P.Parsec String () Type

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

6868

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

70−parseREmpty = braces whiteSpace >> return REmpty

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

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

7171

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

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

74− <*> (parseType <* semi)

75− <*> parseRow

76−

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

78−parseRowVariable = RowVar <$> identifier

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

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

7974

8075parseRow :: P.Parsec String () Row

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

82− [ parseRCons

83− , parseRowVariable

84− , parseREmpty ]

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

77+ where

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

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 (

1818 module PureScript.TypeChecker.Monad,

1919 module PureScript.TypeChecker.Kinds,

2020 module PureScript.TypeChecker.Types,

21− typeCheck,

2221 typeCheckAll,

2322) where

2423

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

4039

4140import qualified Data.Map as M

4241

43−typeCheck :: Declaration -> Check ()

44−typeCheck (DataDeclaration dcs@(DataConstructors

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

43+typeCheckAll [] = return ()

44+typeCheckAll (DataDeclaration dcs@(DataConstructors

4545 { typeConstructorName = name

4646 , typeArguments = args

4747 , dataConstructors = ctors

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

49− env <- getEnv

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

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

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

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

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

55− env' <- getEnv

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

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

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

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

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

61− env <- getEnv

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

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

64− Nothing -> do

65− ty <- typeOf name val

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

67−

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

69−typeCheckAll = mapM_ typeCheck

48+ }) : rest) = do

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

50+ env <- getEnv

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

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

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

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

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

56+ env' <- getEnv

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

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

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

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

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

67+ env <- getEnv

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

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

70+ Nothing -> do

71+ ty <- typeOf name val

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

73+ typeCheckAll rest

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

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

3131 | Function [Type] Type

3232 | TypeVar String

3333 | TypeConstructor String

34− | TypeApp Type Type

34+ | TypeApp Type Type deriving Show

3535

3636data Row

3737 = RUnknown Int

3838 | RowVar String

3939 | REmpty

40− | RCons String Type Row

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

40+ | RCons String Type Row deriving Show