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