git.iko.soy/rowtype-yoga/purescript-native
on 2ffe085 help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen/Externs.hs
105 lines 3.6 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.Arrow ((<+>))
25import qualified Data.Map as M
26import Control.Applicative
28import PureScript.Values
29import PureScript.Types
30import PureScript.Names
31import PureScript.Declarations
32import PureScript.TypeChecker.Monad
33import PureScript.CodeGen.Common
35externToPs :: Environment -> Declaration -> Maybe String
36externToPs env (ValueDeclaration name _) = do
37 (ty, _) <- M.lookup name $ names env
38 return $ "extern " ++ show name ++ " :: " ++ polyTypeToPs ty
39externToPs env (ExternDeclaration name ty) =
40 return $ "extern " ++ show name ++ " :: " ++ polyTypeToPs ty
41externToPs env (TypeSynonymDeclaration name args ty) =
42 return $ "type " ++ name ++ " " ++ intercalate " " args ++ " = " ++ typeToPs ty
43externToPs _ _ = Nothing
45typeLiterals :: Pattern Type String
46typeLiterals = Pattern $ A.Kleisli match
47 where
48 match Number = Just "Number"
49 match String = Just "String"
50 match Boolean = Just "Boolean"
51 match (Array ty) = Just $ "[" ++ typeToPs ty ++ "]"
52 match (Object row) = Just $ "{ " ++ rowToPs row ++ " }"
53 match (TypeVar var) = Just var
54 match (TypeConstructor ctor) = Just ctor
55 match (TUnknown u) = Just $ show u
56 match _ = Nothing
58rowToPs :: Row -> String
59rowToPs = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList
60 where
61 nameAndTypeToPs :: String -> Type -> String
62 nameAndTypeToPs name ty = name ++ " :: " ++ typeToPs ty
63 tailToPs :: Row -> String
64 tailToPs REmpty = ""
65 tailToPs (RUnknown u) = show u
66 tailToPs (RowVar var) = " | " ++ var
67 toList :: Row -> ([(String, Type)], Row)
68 toList (RCons name ty row) = let (tys, rest) = toList row
69 in ((name, ty):tys, rest)
70 toList r = ([], r)
72typeApp :: Pattern Type (Type, Type)
73typeApp = Pattern $ A.Kleisli match
74 where
75 match (TypeApp f x) = Just (f, x)
76 match _ = Nothing
78singleArgumentFunction :: Pattern Type (Type, Type)
79singleArgumentFunction = Pattern $ A.Kleisli match
80 where
81 match (Function [arg] ret) = Just (arg, ret)
82 match _ = Nothing
84function :: Pattern Type ([Type], Type)
85function = Pattern $ A.Kleisli match
86 where
87 match (Function args ret) = Just (args, ret)
88 match _ = Nothing
90typeToPs :: Type -> String
91typeToPs = fromMaybe (error "Incomplete pattern") . pattern matchType
92 where
93 matchType :: Pattern Type String
94 matchType = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchType)
95 operators :: OperatorTable Type String
96 operators =
97 OperatorTable $ [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
98 , [ AssocR singleArgumentFunction $ \arg ret -> arg ++ " -> " ++ ret
99 , Wrap function $ \args ret -> "(" ++ intercalate ", " (map typeToPs args) ++ ") -> " ++ ret
100 ]
101 ]
103polyTypeToPs :: PolyType -> String
104polyTypeToPs (PolyType [] ty) = typeToPs ty
105polyTypeToPs (PolyType idents ty) = "forall " ++ intercalate " " idents ++ ". " ++ typeToPs ty