Skip to content

Commit 9f939a6

Browse files
garybgaryb
committed
Use TypeConstructors for basic types
1 parent b2fb541 commit 9f939a6

File tree

8 files changed

+106
-116
lines changed

8 files changed

+106
-116
lines changed

‎src/Language/PureScript/CodeGen/JS.hs‎

Lines changed: 7 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -128,20 +128,20 @@ runtimeTypeChecks arg ty =
128128
maybe [] (argumentCheck (JSVar arg)) argTy
129129
where
130130
getFunctionArgumentType :: Type -> Maybe Type
131-
getFunctionArgumentType (TypeApp (TypeApp Function funArg) _) = Just funArg
131+
getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg
132132
getFunctionArgumentType (ForAll _ ty') = getFunctionArgumentType ty'
133133
getFunctionArgumentType _ = Nothing
134134
argumentCheck :: JS -> Type -> [JS]
135-
argumentCheck val Number = [typeCheck val "number"]
136-
argumentCheck val String = [typeCheck val "string"]
137-
argumentCheck val Boolean = [typeCheck val "boolean"]
138-
argumentCheck val (TypeApp Array _) = [arrayCheck val]
135+
argumentCheck val t | t == tyNumber = [typeCheck val "number"]
136+
argumentCheck val t | t == tyString = [typeCheck val "string"]
137+
argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]
138+
argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]
139139
argumentCheck val (Object row) =
140140
let
141141
(pairs, _) = rowToList row
142142
in
143143
typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (JSAccessor prop val) ty') pairs
144-
argumentCheck val (TypeApp (TypeApp Function _) _) = [typeCheck val "function"]
144+
argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]
145145
argumentCheck val (ForAll _ ty') = argumentCheck val ty'
146146
argumentCheck _ _ = []
147147
typeCheck :: JS -> String -> JS
@@ -253,7 +253,7 @@ isOnlyConstructor m e ctor =
253253
numConstructors ty = length $ filter (\(ty1, _) -> ((==) `on` typeConstructor) ty ty1) $ M.elems $ dataConstructors e
254254
typeConstructor (TypeConstructor qual) = qualify m qual
255255
typeConstructor (ForAll _ ty) = typeConstructor ty
256-
typeConstructor (TypeApp (TypeApp Function _) ty) = typeConstructor ty
256+
typeConstructor (TypeApp (TypeApp t _) ty) | t == tyFunction = typeConstructor ty
257257
typeConstructor (TypeApp ty _) = typeConstructor ty
258258
typeConstructor fn = error $ "Invalid arguments to typeConstructor: " ++ show fn
259259

‎src/Language/PureScript/Parser/Types.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -27,22 +27,22 @@ import qualified Text.Parsec.Expr as P
2727
import Control.Monad (when, unless)
2828

2929
parseNumber :: P.Parsec String ParseState Type
30-
parseNumber = const Number <$> reserved "Number"
30+
parseNumber = const tyNumber <$> reserved "Number"
3131

3232
parseString :: P.Parsec String ParseState Type
33-
parseString = const String <$> reserved "String"
33+
parseString = const tyString <$> reserved "String"
3434

3535
parseBoolean :: P.Parsec String ParseState Type
36-
parseBoolean = const Boolean <$> reserved "Boolean"
36+
parseBoolean = const tyBoolean <$> reserved "Boolean"
3737

3838
parseArray :: P.Parsec String ParseState Type
39-
parseArray = squares $ return Array
39+
parseArray = squares $ return tyArray
4040

4141
parseArrayOf :: P.Parsec String ParseState Type
42-
parseArrayOf = squares $ TypeApp Array <$> parseType
42+
parseArrayOf = squares $ TypeApp tyArray <$> parseType
4343

4444
parseFunction :: P.Parsec String ParseState Type
45-
parseFunction = parens $ P.try (lexeme (P.string "->")) >> return Function
45+
parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction
4646

4747
parseObject :: P.Parsec String ParseState Type
4848
parseObject = braces $ Object <$> parseRow False

‎src/Language/PureScript/Pretty/Types.hs‎

Lines changed: 1 addition & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -31,11 +31,6 @@ import Language.PureScript.Pretty.Common
3131
typeLiterals :: Pattern () Type String
3232
typeLiterals = mkPattern match
3333
where
34-
match Number = Just "Number"
35-
match String = Just "String"
36-
match Boolean = Just "Boolean"
37-
match Array = Just $ "[]"
38-
match Function = Just $ "(->)"
3934
match (Object row) = Just $ "{ " ++ prettyPrintType row ++ " }"
4035
match (TypeVar var) = Just var
4136
match (TypeConstructor ctor) = Just $ show ctor
@@ -75,7 +70,7 @@ typeApp = mkPattern match
7570
singleArgumentFunction :: Pattern () Type (Type, Type)
7671
singleArgumentFunction = mkPattern match
7772
where
78-
match (TypeApp (TypeApp Function arg) ret) = Just (arg, ret)
73+
match (TypeApp (TypeApp t arg) ret) | t == tyFunction = Just (arg, ret)
7974
match _ = Nothing
8075

8176
-- |

‎src/Language/PureScript/Sugar/TypeClasses.hs‎

Lines changed: 1 addition & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,7 @@ typeInstanceDictionaryDeclaration mn deps name ty decls = do
8888
return $ ValueDeclaration entryName [] Nothing
8989
(TypedValue True
9090
(foldr Abs (ObjectLiteral memberNames) (map (\n -> Ident ('_' : show n)) [1..length deps]))
91-
(quantify (foldr (\t1 t2 -> TypeApp (TypeApp Function t1) t2) (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))
91+
(quantify (foldr function (TypeApp (TypeConstructor name) ty) (map (\(pn, ty') -> TypeApp (TypeConstructor pn) ty') deps)))
9292
)
9393
where
9494
memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
@@ -133,11 +133,6 @@ mkDictionaryValueName mn cl ty = do
133133
return $ Ident $ "__" ++ qualifiedToString mn cl ++ "_" ++ tyStr
134134

135135
typeToString :: ModuleName -> Type -> Either String String
136-
typeToString _ String = return "string"
137-
typeToString _ Number = return "number"
138-
typeToString _ Boolean = return "boolean"
139-
typeToString _ Array = return "array"
140-
typeToString _ Function = return "function"
141136
typeToString _ (TypeVar _) = return "var"
142137
typeToString mn (TypeConstructor ty') = return $ qualifiedToString mn ty'
143138
typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty'

‎src/Language/PureScript/TypeChecker.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -231,7 +231,7 @@ typeCheckAll currentModule (d@(ImportDeclaration moduleName idents) : rest) = do
231231
constructs (TypeConstructor (Qualified (Just mn) pn')) pn
232232
= mn == moduleName && pn' == pn
233233
constructs (ForAll _ ty) pn = ty `constructs` pn
234-
constructs (TypeApp (TypeApp Function _) ty) pn = ty `constructs` pn
234+
constructs (TypeApp (TypeApp t _) ty) pn | t == tyFunction = ty `constructs` pn
235235
constructs (TypeApp ty _) pn = ty `constructs` pn
236236
constructs fn _ = error $ "Invalid arguments to constructs: " ++ show fn
237237
typeCheckAll moduleName (d@(TypeClassDeclaration _ _ _) : rest) = do

‎src/Language/PureScript/TypeChecker/Kinds.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -117,15 +117,15 @@ starIfUnknown k = k
117117
-- Infer a kind for a type
118118
--
119119
infer :: Type -> UnifyT Check Kind
120-
infer Number = return Star
121-
infer String = return Star
122-
infer Boolean = return Star
123-
infer Array = return $ FunKind Star Star
120+
infer t | t == tyNumber = return Star
121+
infer t | t == tyString = return Star
122+
infer t | t == tyBoolean = return Star
123+
infer t | t == tyArray = return $ FunKind Star Star
124+
infer t | t == tyFunction = return $ FunKind Star $ FunKind Star Star
124125
infer (Object row) = do
125126
k <- infer row
126127
k ?= Row Star
127128
return Star
128-
infer Function = return $ FunKind Star $ FunKind Star Star
129129
infer (TypeVar v) = do
130130
Just moduleName <- checkCurrentModule <$> get
131131
UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))

0 commit comments

Comments
 (0)