git.iko.soy/rowtype-yoga/purescript-native
on 7b064bd help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen/Externs.hs
95 lines 3.1 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : PureScript.CodeGen.Externs
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
17module PureScript.CodeGen.Externs (
18 externToPs
19) where
21import Data.Maybe (fromMaybe)
22import Data.List (intersperse, intercalate)
23import qualified Control.Arrow as A
24import Control.Applicative
26import PureScript.Values
27import PureScript.Types
28import PureScript.Names
29import PureScript.Declarations
30import PureScript.TypeChecker.Monad
31import PureScript.CodeGen.Common
33externToPs :: Ident -> (PolyType, NameKind) -> String
34externToPs name (ty, _) = "extern " ++ show name ++ " :: " ++ polyTypeToPs ty
36typeLiterals :: Pattern Type String
37typeLiterals = Pattern $ A.Kleisli match
38 where
39 match Number = Just "Number"
40 match String = Just "String"
41 match Boolean = Just "Boolean"
42 match (Array ty) = Just $ "[" ++ typeToPs ty ++ "]"
43 match (Object row) = Just $ "{ " ++ rowToPs row ++ " }"
44 match (TypeVar var) = Just var
45 match (TypeConstructor ctor) = Just ctor
46 match (TUnknown u) = Just $ show u
47 match _ = Nothing
49rowToPs :: Row -> String
50rowToPs = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList
51 where
52 nameAndTypeToPs :: String -> Type -> String
53 nameAndTypeToPs name ty = name ++ " :: " ++ typeToPs ty
54 tailToPs :: Row -> String
55 tailToPs REmpty = ""
56 tailToPs (RUnknown u) = show u
57 tailToPs (RowVar var) = " | " ++ var
58 toList :: Row -> ([(String, Type)], Row)
59 toList (RCons name ty row) = let (tys, rest) = toList row
60 in ((name, ty):tys, rest)
61 toList r = ([], r)
63typeApp :: Pattern Type (Type, Type)
64typeApp = Pattern $ A.Kleisli match
65 where
66 match (TypeApp f x) = Just (f, x)
67 match _ = Nothing
69singleArgumentFunction :: Pattern Type (Type, Type)
70singleArgumentFunction = Pattern $ A.Kleisli match
71 where
72 match (Function [arg] ret) = Just (arg, ret)
73 match _ = Nothing
75function :: Pattern Type ([Type], Type)
76function = Pattern $ A.Kleisli match
77 where
78 match (Function args ret) = Just (args, ret)
79 match _ = Nothing
81typeToPs :: Type -> String
82typeToPs = fromMaybe (error "Incomplete pattern") . pattern matchType
83 where
84 matchType :: Pattern Type String
85 matchType = buildPrettyPrinter operators (typeLiterals <|> fmap parens matchType)
86 operators :: OperatorTable Type String
87 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
91 ]
93polyTypeToPs :: PolyType -> String
94polyTypeToPs (PolyType [] ty) = typeToPs ty
95polyTypeToPs (PolyType idents ty) = "forall " ++ intercalate " " idents ++ ". " ++ typeToPs ty