cb57250 · rowtype-yoga/purescript-native

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

Starting work on code comments

commitcb572506d84714ace45bc7d8a057fdc14eeadd3a authorPhil Freeman <paf31@cantab.net> dateSun 26 Jan 2014, 23:39 (13 years ago) parent71ebb7b

23 files changed+777−21

compare with golang

unifiedsplit

src/Data/Generics/Extras.hs+4

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Additional SYB combinators

1213--

1314-----------------------------------------------------------------------------

1415

@@ -18,6 +19,9 @@ module Data.Generics.Extras where

1819

1920import Data.Data

2021

22+-- |

23+-- Apply a top-down monadic transformation everywhere

24+--

2125everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d

2226everywhereM' f x = do

2327 y <- f x

src/Language/PureScript.hs+18

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- The main compiler module

1213--

1314-----------------------------------------------------------------------------

1415

@@ -32,6 +33,23 @@ import Control.Monad (when, forM)

3233import Control.Applicative ((<$>))

3334import qualified Data.Map as M

3435

36+-- |

37+-- Compile a collection of modules

38+--

39+-- The compilation pipeline proceeds as follows:

40+--

41+-- * Sort the modules based on module dependencies, checking for cyclic dependencies.

42+--

43+-- * Perform a set of desugaring passes.

44+--

45+-- * Type check, and elaborate values to include type annotations and type class dictionaries.

46+--

47+-- * Regroup values to take into account new value dependencies introduced by elaboration

48+--

49+-- * Generate Javascript, and perform optimization passes.

50+--

51+-- * Pretty-print the generated Javascript

52+--

3553compile :: Options -> [Module] -> Either String (String, String, Environment)

3654compile opts ms = do

3755 sorted <- sortModules ms

src/Language/PureScript/CodeGen.hs+7

@@ -9,6 +9,13 @@

99-- Portability :

1010--

1111-- |

12+-- A collection of modules related to code generation:

13+--

14+-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript

15+--

16+-- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files

17+--

18+-- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript

1219--

1320-----------------------------------------------------------------------------

1421

src/Language/PureScript/Declarations.hs+85−1

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

88-- Stability : experimental

99-- Portability :

1010--

11−-- |

11+-- | Data types for modules and declarations

1212--

1313-----------------------------------------------------------------------------

1414

@@ -24,59 +24,143 @@ import Language.PureScript.CodeGen.JS.AST

2424

2525import qualified Data.Data as D

2626

27+-- |

28+-- A precedence level for an infix operator

29+--

2730type Precedence = Integer

2831

32+-- |

33+-- Associativity for infix operators

34+--

2935data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)

3036

37+-- |

38+-- Fixity data for infix operators

39+--

3140data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)

3241

42+-- |

43+-- A module declaration, consisting of a module name and a list of declarations

44+--

3345data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)

3446

47+-- |

48+-- The type of a foreign import

49+--

3550data ForeignImportType

51+ -- |

52+ -- A regular foreign import

53+ --

3654 = ForeignImport

55+ -- |

56+ -- A type class dictionary import, generated during desugaring of type class declarations

57+ --

3758 | TypeClassDictionaryImport

59+ -- |

60+ -- A type class dictionary member accessor import, generated during desugaring of type class declarations

61+ --

3862 | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)

3963

64+-- |

65+-- The data type of declarations

66+--

4067data Declaration

68+ -- |

69+ -- A data type declaration (name, arguments, data constructors)

70+ --

4171 = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]

72+ -- |

73+ -- A minimal mutually recursive set of data type declarations

74+ --

4275 | DataBindingGroupDeclaration [Declaration]

76+ -- |

77+ -- A type synonym declaration (name, arguments, type)

78+ --

4379 | TypeSynonymDeclaration ProperName [String] Type

80+ -- |

81+ -- A type declaration for a value (name, ty)

82+ --

4483 | TypeDeclaration Ident Type

84+ -- |

85+ -- A value declaration (name, top-level binders, optional guard, value)

86+ --

4587 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value

88+ -- |

89+ -- A minimal mutually recursive set of value declarations

90+ --

4691 | BindingGroupDeclaration [(Ident, Value)]

92+ -- |

93+ -- A foreign import declaration (type, name, optional inline Javascript, type)

94+ --

4795 | ExternDeclaration ForeignImportType Ident (Maybe JS) Type

96+ -- |

97+ -- A data type foreign import (name, kind)

98+ --

4899 | ExternDataDeclaration ProperName Kind

100+ -- |

101+ -- A fixity declaration (fixity data, operator name)

102+ --

49103 | FixityDeclaration Fixity String

104+ -- |

105+ -- A module import (module name, optional set of identifiers to import)

106+ --

50107 | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])

108+ -- |

109+ -- A type class declaration (name, argument, member declarations)

110+ --

51111 | TypeClassDeclaration ProperName String [Declaration]

112+ -- |

113+ -- A type instance declaration (dependencies, class name, instance type, member declarations)

114+ --

52115 | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]

53116 deriving (Show, D.Data, D.Typeable)

54117

118+-- |

119+-- Test if a declaration is a value declaration

120+--

55121isValueDecl :: Declaration -> Bool

56122isValueDecl (ValueDeclaration _ _ _ _) = True

57123isValueDecl _ = False

58124

125+-- |

126+-- Test if a declaration is a data type or type synonym declaration

127+--

59128isDataDecl :: Declaration -> Bool

60129isDataDecl (DataDeclaration _ _ _) = True

61130isDataDecl (TypeSynonymDeclaration _ _ _) = True

62131isDataDecl _ = False

63132

133+-- |

134+-- Test if a declaration is a module import

135+--

64136isImportDecl :: Declaration -> Bool

65137isImportDecl (ImportDeclaration _ _) = True

66138isImportDecl _ = False

67139

140+-- |

141+-- Test if a declaration is a data type foreign import

142+--

68143isExternDataDecl :: Declaration -> Bool

69144isExternDataDecl (ExternDataDeclaration _ _) = True

70145isExternDataDecl _ = False

71146

147+-- |

148+-- Test if a declaration is a fixity declaration

149+--

72150isFixityDecl :: Declaration -> Bool

73151isFixityDecl (FixityDeclaration _ _) = True

74152isFixityDecl _ = False

75153

154+-- |

155+-- Test if a declaration is a foreign import

156+--

76157isExternDecl :: Declaration -> Bool

77158isExternDecl (ExternDeclaration _ _ _ _) = True

78159isExternDecl _ = False

79160

161+-- |

162+-- Test if a declaration is a type class or instance declaration

163+--

80164isTypeClassDeclaration :: Declaration -> Bool

81165isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True

82166isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True

src/Language/PureScript/Kinds.hs+18

@@ -19,9 +19,27 @@ module Language.PureScript.Kinds where

1919import Data.Data

2020import Language.PureScript.Unknown

2121

22+-- |

23+-- The data type of kinds

24+--

2225data Kind

26+ -- |

27+ -- Unification variable of type Kind

28+ --

2329 = KUnknown (Unknown Kind)

30+ -- |

31+ -- The kind of types

32+ --

2433 | Star

34+ -- |

35+ -- The kind of effects

36+ --

2537 | Bang

38+ -- |

39+ -- Kinds for labelled, unordered rows without duplicates

40+ --

2641 | Row Kind

42+ -- |

43+ -- Function kinds

44+ --

2745 | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)

src/Language/PureScript/ModuleDependencies.hs+12−8

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

88-- Stability : experimental

99-- Portability :

1010--

11−-- |

11+-- | Provides the ability to sort modules based on module dependencies

1212--

1313-----------------------------------------------------------------------------

1414

@@ -27,18 +27,19 @@ import Language.PureScript.Names

2727import Language.PureScript.Values

2828import Language.PureScript.Types

2929

30+-- |

31+-- Sort a collection of modules based on module dependencies.

32+--

33+-- Reports an error if the module graph contains a cycle.

34+--

3035sortModules :: [Module] -> Either String [Module]

3136sortModules ms = do

3237 let verts = map (\m -> (m, getModuleName m, usedModules m)) ms

3338 mapM toModule $ stronglyConnComp verts

3439

35−collapseBindingGroups :: [Declaration] -> [Declaration]

36−collapseBindingGroups ds = concatMap go ds

37− where

38− go (DataBindingGroupDeclaration ds) = ds

39− go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds

40− go other = [other]

41−

40+-- |

41+-- Calculate a list of used modules based on explicit imports and qualified names

42+--

4243usedModules :: (Data d) => d -> [ProperName]

4344usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)

4445 where

@@ -55,6 +56,9 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp

5556getModuleName :: Module -> ProperName

5657getModuleName (Module pn _) = pn

5758

59+-- |

60+-- Convert a strongly connected component of the module graph to a module

61+--

5862toModule :: SCC Module -> Either String Module

5963toModule (AcyclicSCC m) = return m

6064toModule (CyclicSCC [m]) = return m

src/Language/PureScript/Names.hs+25−1

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Data types for names

1213--

1314-----------------------------------------------------------------------------

1415

@@ -18,28 +19,51 @@ module Language.PureScript.Names where

1819

1920import Data.Data

2021

21−data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)

22+-- |

23+-- Names for value identifiers

24+--

25+data Ident

26+ -- |

27+ -- An alphanumeric identifier

28+ --

29+ = Ident String

30+ -- |

31+ -- A symbolic name for an infix operator

32+ --

33+ | Op String deriving (Eq, Ord, Data, Typeable)

2234

2335instance Show Ident where

2436 show (Ident s) = s

2537 show (Op op) = '(':op ++ ")"

2638

39+-- |

40+-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

41+--

2742newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)

2843

2944instance Show ProperName where

3045 show = runProperName

3146

47+-- |

48+-- Module names

49+--

3250data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)

3351

3452instance Show ModuleName where

3553 show (ModuleName name) = show name

3654

55+-- |

56+-- A qualified name, i.e. a name with an optional module name

57+--

3758data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)

3859

3960instance (Show a) => Show (Qualified a) where

4061 show (Qualified Nothing a) = show a

4162 show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a

4263

64+-- |

65+-- Provide a default module name, if a name is unqualified

66+--

4367qualify :: ModuleName -> Qualified a -> (ModuleName, a)

4468qualify m (Qualified Nothing a) = (m, a)

4569qualify _ (Qualified (Just m) a) = (m, a)

src/Language/PureScript/Options.hs+21−2

@@ -9,17 +9,36 @@

99-- Portability :

1010--

1111-- |

12+-- The data type of compiler options

1213--

1314-----------------------------------------------------------------------------

1415

1516module Language.PureScript.Options where

1617

17−data Options = Options

18− { optionsTco :: Bool

18+-- |

19+-- The data type of compiler options

20+--

21+data Options = Options {

22+ -- |

23+ -- Perform tail-call elimination

24+ --

25+ optionsTco :: Bool

26+ -- |

27+ -- Perform type checks at runtime

28+ --

1929 , optionsPerformRuntimeTypeChecks :: Bool

30+ -- |

31+ -- Inline calls to ret and bind for the Eff monad

32+ --

2033 , optionsMagicDo :: Bool

34+ -- |

35+ -- Check the type of Main.main and generate its code

36+ --

2137 , optionsRunMain :: Bool

2238 } deriving Show

2339

40+-- |

41+-- Default compiler options

42+--

2443defaultOptions :: Options

2544defaultOptions = Options False False False False

src/Language/PureScript/Parser.hs+13

@@ -9,6 +9,19 @@

99-- Portability :

1010--

1111-- |

12+-- A collection of parsers for core data types:

13+--

14+-- [@Language.PureScript.Parser.Kinds@] Parser for kinds

15+--

16+-- [@Language.PureScript.Parser.Values@] Parser for values

17+--

18+-- [@Language.PureScript.Parser.Types@] Parser for types

19+--

20+-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules

21+--

22+-- [@Language.PureScript.Parser.State@] Parser state, including indentation

23+--

24+-- [@Language.PureScript.Parser.Common@] Common parsing utility functions

1225--

1326-----------------------------------------------------------------------------

1427

src/Language/PureScript/Pretty.hs+9

@@ -9,6 +9,15 @@

99-- Portability :

1010--

1111-- |

12+-- A collection of pretty printers for core data types:

13+--

14+-- [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds

15+--

16+-- [@Language.PureScript.Pretty.Values@] Pretty printer for values

17+--

18+-- [@Language.PureScript.Pretty.Types@] Pretty printer for types

19+--

20+-- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation

1221--

1322-----------------------------------------------------------------------------

1423

src/Language/PureScript/Pretty/Common.hs+56

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Common pretty-printing utility functions

1213--

1314-----------------------------------------------------------------------------

1415

@@ -25,6 +26,13 @@ import Control.Arrow ((***), (<+>))

2526

2627import Language.PureScript.Names

2728

29+-- |

30+-- Convert an Ident into a valid Javascript identifier:

31+--

32+-- * Alphanumeric characters are kept unmodified

33+--

34+-- * Symbols are encoded as a dollar symbol ($) followed by their ordinal value

35+--

2836identToJs :: Ident -> String

2937identToJs (Ident name) = concatMap identCharToString name

3038identToJs (Op op) = concatMap identCharToString op

@@ -34,43 +42,91 @@ identCharToString c | isAlphaNum c = [c]

3442identCharToString '_' = "_"

3543identCharToString c = '$' : show (ord c)

3644

45+-- |

46+-- A first-order pattern match

47+--

48+-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.

49+--

3750newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)

3851

3952instance Functor (Pattern u a) where

4053 fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p

4154

55+-- |

56+-- Run a pattern with an input and initial user state

57+--

58+-- Returns Nothing if the pattern fails to match

59+--

4260pattern :: Pattern u a b -> u -> a -> Maybe b

4361pattern p u = flip evalStateT u . A.runKleisli (runPattern p)

4462

63+-- |

64+-- Construct a pattern from a function

65+--

4566mkPattern :: (a -> Maybe b) -> Pattern u a b

4667mkPattern f = Pattern $ A.Kleisli (lift . f)

4768

69+-- |

70+-- Construct a pattern from a stateful function

71+--

4872mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b

4973mkPattern' = Pattern . A.Kleisli

5074

75+-- |

76+-- Wrap a string in parentheses

77+--

5178parens :: String -> String

5279parens s = ('(':s) ++ ")"

5380

81+-- |

82+-- Construct a pattern which recursively matches on the left-hand-side

83+--

5484chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r

5585chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)

5686

87+-- |

88+-- Construct a pattern which recursively matches on the right-hand side

89+--

5790chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r

5891chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)

5992

93+-- |

94+-- Construct a pattern which recursively matches on one-side of a tuple

95+--

6096wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r

6197wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)

6298

99+-- |

100+-- Construct a pattern which matches a part of a tuple

101+--

63102split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r

64103split s f = s >>> A.arr (uncurry f)

65104

105+-- |

106+-- A table of operators

107+--

66108data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }

67109

110+-- |

111+-- An operator:

112+--

113+-- [@AssocL@] A left-associative operator

114+--

115+-- [@AssocR@] A right-associative operator

116+--

117+-- [@Wrap@] A prefix-like or postfix-like operator

118+--

119+-- [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand

120+--

68121data Operator u a r where

69122 AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r

70123 AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r

71124 Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r

72125 Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r

73126

127+-- |

128+-- Build a pretty printer from an operator table and an indecomposable pattern

129+--

74130buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r

75131buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->

76132 case op of

src/Language/PureScript/Pretty/JS.hs+19

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Pretty printer for the Javascript AST

1213--

1314-----------------------------------------------------------------------------

1415

@@ -30,9 +31,15 @@ import Control.Monad.State

3031

3132newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)

3233

34+-- |

35+-- Number of characters per identation level

36+--

3337blockIndent :: Int

3438blockIndent = 4

3539

40+-- |

41+-- Pretty print with a new indentation level

42+--

3643withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String

3744withIndent action = do

3845 modify $ \st -> st { indent = indent st + blockIndent }

@@ -40,6 +47,9 @@ withIndent action = do

4047 modify $ \st -> st { indent = indent st - blockIndent }

4148 return result

4249

50+-- |

51+-- Get the current indentation level

52+--

4353currentIndent :: StateT PrinterState Maybe String

4454currentIndent = do

4555 current <- get

@@ -187,15 +197,24 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

187197 match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)

188198 match' _ = Nothing

189199

200+-- |

201+-- Generate a pretty-printed string representing a Javascript expression

202+--

190203prettyPrintJS1 :: JS -> String

191204prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

192205

206+-- |

207+-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

208+--

193209prettyPrintJS :: [JS] -> String

194210prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do

195211 jss <- forM sts prettyPrintJS'

196212 indentString <- currentIndent

197213 return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss

198214

215+-- |

216+-- Generate an indented, pretty-printed string representing a Javascript expression

217+--

199218prettyPrintJS' :: JS -> StateT PrinterState Maybe String

200219prettyPrintJS' = A.runKleisli $ runPattern matchValue

201220 where

src/Language/PureScript/Pretty/Kinds.hs+4

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Pretty printer for kinds

1213--

1314-----------------------------------------------------------------------------

1415

@@ -43,6 +44,9 @@ funKind = mkPattern match

4344 match (FunKind arg ret) = Just (arg, ret)

4445 match _ = Nothing

4546

47+-- |

48+-- Generate a pretty-printed string representing a Kind

49+--

4650prettyPrintKind :: Kind -> String

4751prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()

4852 where

src/Language/PureScript/Pretty/Types.hs+7

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Pretty printer for Types

1213--

1314-----------------------------------------------------------------------------

1415

@@ -44,6 +45,9 @@ typeLiterals = mkPattern match

4445 match row@(RCons _ _ _) = Just $ prettyPrintRow row

4546 match _ = Nothing

4647

48+-- |

49+-- Generate a pretty-printed string representing a Row

50+--

4751prettyPrintRow :: Type -> String

4852prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []

4953 where

@@ -77,6 +81,9 @@ function = mkPattern match

7781 match (Function args ret) = Just (args, ret)

7882 match _ = Nothing

7983

84+-- |

85+-- Generate a pretty-printed string representing a Type

86+--

8087prettyPrintType :: Type -> String

8188prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()

8289 where

src/Language/PureScript/Pretty/Values.hs+7

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Pretty printer for values

1213--

1314-----------------------------------------------------------------------------

1415

@@ -113,6 +114,9 @@ prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val

113114prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val

114115prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val

115116

117+-- |

118+-- Generate a pretty-printed string representing a Value

119+--

116120prettyPrintValue :: Value -> String

117121prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()

118122 where

@@ -170,6 +174,9 @@ prettyPrintBinderAtom = mkPattern match

170174 match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder

171175 match _ = Nothing

172176

177+-- |

178+-- Generate a pretty-printed string representing a Binder

179+--

173180prettyPrintBinder :: Binder -> String

174181prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()

175182 where

src/Language/PureScript/Scope.hs+7

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Utility functions for working with names in scope

1213--

1314-----------------------------------------------------------------------------

1415

@@ -25,6 +26,9 @@ import Language.PureScript.Values

2526import Language.PureScript.Names

2627import Language.PureScript.CodeGen.JS.AST

2728

29+-- |

30+-- Gather all used names appearing inside a value

31+--

2832usedNames :: (Data d) => d -> [Ident]

2933usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val

3034 where

@@ -47,6 +51,9 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB

4751 namesJS (JSFor name _ _ _) = [name]

4852 namesJS _ = []

4953

54+-- |

55+-- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@

56+--

5057unusedNames :: (Data d) => d -> [Ident]

5158unusedNames val =

5259 let

src/Language/PureScript/Sugar.hs+16

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Desugaring passes

1213--

1314-----------------------------------------------------------------------------

1415

@@ -25,6 +26,21 @@ import Language.PureScript.Sugar.TypeDeclarations as S

2526import Language.PureScript.Sugar.BindingGroups as S

2627import Language.PureScript.Sugar.TypeClasses as S

2728

29+-- |

30+-- The desugaring pipeline proceeds as follows:

31+--

32+-- * Introduce type synonyms for type class dictionaries

33+--

34+-- * Rebracket user-defined binary operators

35+--

36+-- * Desugar do-notation using the @Prelude.Monad@ type class

37+--

38+-- * Desugar top-level case declarations into explicit case expressions

39+--

40+-- * Desugar type declarations into value declarations with explicit type annotations

41+--

42+-- * Group mutually recursive value and data declarations into binding groups.

43+--

2844desugar :: [Module] -> Either String [Module]

2945desugar = desugarTypeClasses

3046 >=> rebracket

src/Language/PureScript/TypeChecker/Kinds.hs+19

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- This module implements the kind checker

1213--

1314-----------------------------------------------------------------------------

1415

@@ -57,9 +58,15 @@ instance Unifiable Kind where

5758 unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2

5859 unknowns _ = []

5960

61+-- |

62+-- Infer the kind of a single type

63+--

6064kindOf :: ModuleName -> Type -> Check Kind

6165kindOf moduleName ty = fmap (\(k, s) -> apply s k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty

6266

67+-- |

68+-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors

69+--

6370kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind

6471kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k)) . runSubst (SubstContext moduleName) $ do

6572 tyCon <- fresh

@@ -68,6 +75,9 @@ kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k))

6875 bindLocalTypeVariables moduleName dict $

6976 solveTypes ts kargs tyCon

7077

78+-- |

79+-- Simultaneously infer the kinds of several mutually recursive type constructors

80+--

7181kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])

7282kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName) $ do

7383 synVars <- replicateM (length syns) fresh

@@ -90,6 +100,9 @@ kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName

90100 where

91101 tidyUp ((ks1, ks2), s) = (map starIfUnknown $ apply s ks1, map starIfUnknown $ apply s ks2)

92102

103+-- |

104+-- Solve the set of kind constraints associated with the data constructors for a type constructor

105+--

93106solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind

94107solveTypes ts kargs tyCon = do

95108 ks <- mapM infer ts

@@ -97,11 +110,17 @@ solveTypes ts kargs tyCon = do

97110 forM_ ks $ \k -> k ~~ Star

98111 return tyCon

99112

113+-- |

114+-- Default all unknown kinds to the Star kind of types

115+--

100116starIfUnknown :: Kind -> Kind

101117starIfUnknown (KUnknown _) = Star

102118starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)

103119starIfUnknown k = k

104120

121+-- |

122+-- Infer a kind for a type

123+--

105124infer :: Type -> Subst Kind

106125infer Number = return Star

107126infer String = return Star

src/Language/PureScript/TypeChecker/Monad.hs+178−6

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Monads for type checking and type inference and associated data types

1213--

1314-----------------------------------------------------------------------------

1415

@@ -37,31 +38,91 @@ import Control.Arrow ((***))

3738

3839import qualified Data.Map as M

3940

41+-- |

42+-- The type of a name in the @Environment@

43+--

4044data NameKind

45+ -- |

46+ -- A value introduced as a binding in a module

47+ --

4148 = Value

49+ -- |

50+ -- A foreign import

51+ --

4252 | Extern ForeignImportType

53+ -- |

54+ -- An alias for a value in another module, introduced using an import declaration

55+ --

4356 | Alias ModuleName Ident

57+ -- |

58+ -- A local name introduced using a lambda abstraction, variable introduction or binder

59+ --

4460 | LocalVariable

61+ -- |

62+ -- A data constructor

63+ --

4564 | DataConstructor deriving Show

4665

66+-- |

67+-- The type of a type declaration

68+--

4769data TypeDeclarationKind

70+ -- |

71+ -- A data constructor

72+ --

4873 = Data

74+ -- |

75+ -- A data type foreign import

76+ --

4977 | ExternData

78+ -- |

79+ -- A type synonym

80+ --

5081 | TypeSynonym

82+ -- |

83+ -- An alias for a type in another module, introduced using an import declaration

84+ --

5185 | DataAlias ModuleName ProperName

86+ -- |

87+ -- A local type name introduced using a forall quantifier

88+ --

5289 | LocalTypeVariable deriving Show

5390

54−data Environment = Environment

55− { names :: M.Map (ModuleName, Ident) (Type, NameKind)

91+-- |

92+-- The @Environment@ defines all values and types which are currently in scope:

93+--

94+data Environment = Environment {

95+ -- |

96+ -- Value names currently in scope

97+ --

98+ names :: M.Map (ModuleName, Ident) (Type, NameKind)

99+ -- |

100+ -- Type names currently in scope

101+ --

56102 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)

103+ -- |

104+ -- Data constructors currently in scope, along with their associated data type constructors

105+ --

57106 , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)

107+ -- |

108+ -- Type synonyms currently in scope

109+ --

58110 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)

111+ -- |

112+ -- Available type class dictionaries

113+ --

59114 , typeClassDictionaries :: [TypeClassDictionaryInScope]

60115 } deriving (Show)

61116

117+-- |

118+-- An empty environment with no values and no types defined

119+--

62120emptyEnvironment :: Environment

63121emptyEnvironment = Environment M.empty M.empty M.empty M.empty []

64122

123+-- |

124+-- Temporarily bind a collection of names to values

125+--

65126bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a

66127bindNames newNames action = do

67128 orig <- get

@@ -70,6 +131,9 @@ bindNames newNames action = do

70131 modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }

71132 return a

72133

134+-- |

135+-- Temporarily bind a collection of names to types

136+--

73137bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a

74138bindTypes newNames action = do

75139 orig <- get

@@ -78,6 +142,9 @@ bindTypes newNames action = do

78142 modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }

79143 return a

80144

145+-- |

146+-- Temporarily make a collection of type class dictionaries available

147+--

81148withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a

82149withTypeClassDictionaries entries action = do

83150 orig <- get

@@ -86,17 +153,29 @@ withTypeClassDictionaries entries action = do

86153 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }

87154 return a

88155

156+-- |

157+-- Get the currently available list of type class dictionaries

158+--

89159getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]

90160getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get

91161

162+-- |

163+-- Temporarily bind a collection of names to local variables

164+--

92165bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a

93166bindLocalVariables moduleName bindings action =

94167 bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action

95168

169+-- |

170+-- Temporarily bind a collection of names to local type variables

171+--

96172bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a

97173bindLocalTypeVariables moduleName bindings action =

98174 bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action

99175

176+-- |

177+-- Lookup the type of a value by name in the @Environment@

178+--

100179lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type

101180lookupVariable currentModule (Qualified moduleName var) = do

102181 env <- getEnv

@@ -104,6 +183,9 @@ lookupVariable currentModule (Qualified moduleName var) = do

104183 Nothing -> throwError $ show var ++ " is undefined"

105184 Just (ty, _) -> return ty

106185

186+-- |

187+-- Lookup the kind of a type by name in the @Environment@

188+--

107189lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind

108190lookupTypeVariable currentModule (Qualified moduleName name) = do

109191 env <- getEnv

@@ -111,63 +193,120 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do

111193 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"

112194 Just (k, _) -> return k

113195

196+-- |

197+-- Canonicalize an identifier by resolving any aliases introduced by module imports

198+--

114199canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)

115200canonicalize _ _ (Qualified (Just mn) i) = (mn, i)

116201canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of

117202 Just (_, Alias mn' i') -> (mn', i')

118203 _ -> (mn, i)

119204

205+-- |

206+-- Canonicalize a type variable by resolving any aliases introduced by module imports

207+--

120208canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)

121209canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)

122210canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of

123211 Just (_, DataAlias mn' pn') -> (mn', pn')

124212 _ -> (mn, nm)

125213

126−data CheckState = CheckState { checkEnv :: Environment

127− , checkNextVar :: Int

128− , checkNextDictName :: Int

129− }

214+-- |

215+-- State required for type checking:

216+--

217+data CheckState = CheckState {

218+ -- |

219+ -- The current @Environment@

220+ --

221+ checkEnv :: Environment

222+ -- |

223+ -- The next fresh unification variable name

224+ --

225+ , checkNextVar :: Int

226+ -- |

227+ -- The next type class dictionary name

228+ --

229+ , checkNextDictName :: Int

230+ }

130231

232+-- |

233+-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

234+--

131235newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }

132236 deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)

133237

238+-- |

239+-- Get the current @Environment@

240+--

134241getEnv :: (Functor m, MonadState CheckState m) => m Environment

135242getEnv = checkEnv <$> get

136243

244+-- |

245+-- Update the @Environment#

246+--

137247putEnv :: (MonadState CheckState m) => Environment -> m ()

138248putEnv env = modify (\s -> s { checkEnv = env })

139249

250+-- |

251+-- Modify the @Environment@

252+--

140253modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()

141254modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

142255

256+-- |

257+-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

258+--

143259runCheck :: Check a -> Either String (a, Environment)

144260runCheck c = do

145261 (a, s) <- flip runStateT (CheckState emptyEnvironment 0 0) $ unCheck c

146262 return (a, checkEnv s)

147263

264+-- |

265+-- Make an assertion, failing with an error message

266+--

148267guardWith :: (MonadError e m) => e -> Bool -> m ()

149268guardWith _ True = return ()

150269guardWith e False = throwError e

151270

271+-- |

272+-- Rethrow an error with a more detailed error message in the case of failure

273+--

152274rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

153275rethrow f = flip catchError $ \e -> throwError (f e)

154276

277+-- |

278+-- Generate new type class dictionary name

279+--

155280freshDictionaryName :: Check Int

156281freshDictionaryName = do

157282 n <- checkNextDictName <$> get

158283 modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }

159284 return n

160285

286+-- |

287+-- A substitution maintains a mapping from unification variables to their values, ensuring that

288+-- the type of a unification variable matches the type of its value.

289+--

161290newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }

162291

163292instance Monoid Substitution where

164293 mempty = Substitution unknown

165294 s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u))

166295

296+-- |

297+-- State for the substitution monad, which contains the current substitution

298+--

167299data SubstState = SubstState { substSubst :: Substitution }

168300

301+-- |

302+-- Configuration for the substitution monad, constaining the current module

303+--

169304newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)

170305

306+-- |

307+-- The substitution monad, which provides the means to unify values to generate a substitution, in addition to

308+-- the actions supported by the type checking monad @Check@.

309+--

171310newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }

172311 deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)

173312

@@ -177,28 +316,46 @@ instance MonadState CheckState Subst where

177316

178317deriving instance MonadError String Subst

179318

319+-- |

320+-- Lift a computation in the @Check@ monad into the substitution monad.

321+--

180322liftCheck :: Check a -> Subst a

181323liftCheck = Subst . lift . lift

182324

325+-- |

326+-- Get the current substitution monad state

327+--

183328getSubstState :: Subst SubstState

184329getSubstState = Subst . lift $ get

185330

331+-- |

332+-- Run a computation in the substitution monad, generating a return value and the final substitution.

333+--

186334runSubst :: SubstContext -> Subst a -> Check (a, Substitution)

187335runSubst context subst = do

188336 (a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst

189337 return (a, substSubst s)

190338

339+-- |

340+-- Generate a substitution from a substitution function for a single type

341+--

191342substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution

192343substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do

193344 u1 <- cast u

194345 cast (f u1)

195346

347+-- |

348+-- Substitute a single unification variable

349+--

196350substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution

197351substituteOne u t = substituteWith $ \u1 ->

198352 case u1 of

199353 u2 | u2 == u -> t

200354 | otherwise -> unknown u2

201355

356+-- |

357+-- Replace a unification variable with the specified value in the current substitution

358+--

202359replace :: (Unifiable t) => Unknown t -> t -> Subst ()

203360replace u t' = do

204361 sub <- substSubst <$> Subst get

@@ -210,6 +367,9 @@ replace u t' = do

210367 _ -> current ~~ t

211368 Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s }

212369

370+-- |

371+-- Identifies types which support unification

372+--

213373class (Typeable t, Data t, Show t) => Unifiable t where

214374 unknown :: Unknown t -> t

215375 (~~) :: t -> t -> Subst ()

@@ -224,21 +384,33 @@ instance (Unifiable a) => Unifiable [a] where

224384 apply s = map (apply s)

225385 unknowns = concatMap unknowns

226386

387+-- |

388+-- Perform the occurs check, to make sure a unification variable does not occur inside a value

389+--

227390occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()

228391occursCheck (Unknown u) t =

229392 case isUnknown t of

230393 Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)

231394 _ -> return ()

232395

396+-- |

397+-- Generate a fresh untyped unification variable

398+--

233399fresh' :: Subst Int

234400fresh' = do

235401 n <- checkNextVar <$> get

236402 modify $ \s -> s { checkNextVar = succ (checkNextVar s) }

237403 return n

238404

405+-- |

406+-- Generate a fresh unification variable at a specific type

407+--

239408fresh :: (Unifiable t) => Subst t

240409fresh = unknown . Unknown <$> fresh'

241410

411+-- |

412+-- Replace any unqualified names in a type wit their qualified versionss

413+--

242414qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d

243415qualifyAllUnqualifiedNames mn env = everywhere (mkT go)

244416 where

src/Language/PureScript/TypeChecker/Synonyms.hs+10

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor

1213--

1314-----------------------------------------------------------------------------

1415

@@ -28,6 +29,9 @@ import Data.Generics.Extras

2829import Control.Monad.Writer

2930import Control.Monad.Error

3031

32+-- |

33+-- Build a type substitution for a type synonym

34+--

3135buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)

3236buildTypeSubstitution env moduleName name n = go n []

3337 where

@@ -37,11 +41,17 @@ buildTypeSubstitution env moduleName name n = go n []

3741 go m args (TypeApp f arg) = go (m - 1) (arg:args) f

3842 go _ _ _ = return Nothing

3943

44+-- |

45+-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor

46+--

4047saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d

4148saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)

4249 where

4350 replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t

4451

52+-- |

53+-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor

54+--

4555saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d

4656saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns

4757

src/Language/PureScript/TypeChecker/Types.hs+165−3

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- This module implements the type checker

1213--

1314-----------------------------------------------------------------------------

1415

@@ -67,6 +68,9 @@ instance Unifiable Type where

6768 unknowns (RCons _ ty r) = unknowns ty ++ unknowns r

6869 unknowns _ = []

6970

71+-- |

72+-- Unify two types, updating the current substitution

73+--

7074unifyTypes :: Type -> Type -> Subst ()

7175unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do

7276 unifyTypes' t1 t2

@@ -110,6 +114,13 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +

110114 unifyTypes' r1 r2@REmpty = unifyRows r1 r2

111115 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."

112116

117+-- |

118+-- Unify two rows, updating the current substitution

119+--

120+-- Common labels are first identified, and unified. Remaining labels and types are unified with a

121+-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification

122+-- error.

123+--

113124unifyRows :: Type -> Type -> Subst ()

114125unifyRows r1 r2 =

115126 let

@@ -136,9 +147,16 @@ unifyRows r1 r2 =

136147 unifyRows' [] (Skolem s1) [] (Skolem s2) | s1 == s2 = return ()

137148 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."

138149

150+-- |

151+-- Ensure type constructors are equal after canonicalization

152+--

139153typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool

140154typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env

141155

156+-- |

157+-- Infer the types of multiple mutually-recursive values, and return elaborated values including

158+-- type class dictionaries and type annotations.

159+--

142160typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]

143161typesOf moduleName vals = do

144162 tys <- fmap (\(tys, s) -> map (\(ident, (val, ty)) -> (ident, (overTypes (apply s) val, apply s ty))) tys)

@@ -173,19 +191,32 @@ typesOf moduleName vals = do

173191 return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'

174192 , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))

175193

194+-- |

195+-- Check if a value contains a type annotation

196+--

176197isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))

177198isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))

178199isTyped (name, value) = (name, (value, Nothing))

179200

201+-- |

202+-- Map a function over type annotations appearing inside a value

203+--

180204overTypes :: (Type -> Type) -> Value -> Value

181205overTypes f = everywhere (mkT f)

182206

207+-- |

208+-- Replace type class dictionary placeholders with inferred type class dictionaries

209+--

183210replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value

184211replaceTypeClassDictionaries mn = everywhereM (mkM go)

185212 where

186213 go (TypeClassDictionary constraint dicts) = entails mn dicts constraint

187214 go other = return other

188215

216+-- |

217+-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,

218+-- return a type class dictionary reference.

219+--

189220entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value

190221entails moduleName context goal@(className, ty) = do

191222 env <- getEnv

@@ -211,6 +242,10 @@ entails moduleName context goal@(className, ty) = do

211242 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm

212243 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm

213244

245+-- |

246+-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),

247+-- and return a substitution from type variables to types which makes the type heads unify.

248+--

214249typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]

215250typeHeadsAreEqual _ _ String String = Just []

216251typeHeadsAreEqual _ _ Number Number = Just []

@@ -222,6 +257,9 @@ typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <

222257typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1

223258typeHeadsAreEqual _ _ _ _ = Nothing

224259

260+-- |

261+-- Ensure unsolved unification variables do not escape

262+--

225263escapeCheck :: Value -> Type -> Subst ()

226264escapeCheck value ty = do

227265 subst <- substSubst <$> getSubstState

@@ -231,12 +269,18 @@ escapeCheck value ty = do

231269 let unsolvedUnknowns = nub . unknowns $ apply subst t

232270 guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns

233271

272+-- |

273+-- Find all type annotations occuring inside a value

274+--

234275findAllTypes :: Value -> [Type]

235276findAllTypes = everything (++) (mkQ [] go)

236277 where

237278 go (TypedValue _ _ ty) = [ty]

238279 go _ = []

239280

281+-- |

282+-- Ensure skolem variables do not escape their scope

283+--

240284skolemEscapeCheck :: Type -> Check ()

241285skolemEscapeCheck ty =

242286 case something (mkQ Nothing findSkolems) ty of

@@ -246,12 +290,21 @@ skolemEscapeCheck ty =

246290 findSkolems (Skolem _) = return ()

247291 findSkolems _ = mzero

248292

293+-- |

294+-- Ensure a row contains no duplicate labels

295+--

249296setify :: Type -> Type

250297setify = rowFromList . first (M.toList . M.fromList) . rowToList

251298

299+-- |

300+-- \"Setify\" all rows occuring inside a value

301+--

252302setifyAll :: (D.Data d) => d -> d

253303setifyAll = everywhere (mkT setify)

254304

305+-- |

306+-- Replace outermost unsolved unification variables with named type variables

307+--

255308varIfUnknown :: Type -> Type

256309varIfUnknown ty =

257310 let unks = nub $ unknowns ty

@@ -262,18 +315,31 @@ varIfUnknown ty =

262315 typeToVar t = t

263316 in mkForAll (sort . map toName $ unks) ty'

264317

318+-- |

319+-- Replace named type variables with types

320+--

265321replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d

266322replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id

267323

324+-- |

325+-- Replace named type variables with new unification variables

326+--

268327replaceAllVarsWithUnknowns :: Type -> Subst Type

269328replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns

270329replaceAllVarsWithUnknowns ty = return ty

271330

331+-- |

332+-- Replace a single type variable with a new unification variable

333+--

272334replaceVarWithUnknown :: String -> Type -> Subst Type

273335replaceVarWithUnknown ident ty = do

274336 tu <- fresh

275337 return $ replaceTypeVars ident tu $ ty

276338

339+-- |

340+-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate

341+-- better error messages during unification.

342+--

277343replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d

278344replaceAllTypeSynonyms d = do

279345 env <- getEnv

@@ -281,12 +347,18 @@ replaceAllTypeSynonyms d = do

281347 let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env

282348 either throwError return $ saturateAllTypeSynonyms env moduleName syns d

283349

350+-- |

351+-- \"Desaturate\" @SaturatedTypeSynonym@s

352+--

284353desaturateAllTypeSynonyms :: (D.Data d) => d -> d

285354desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)

286355 where

287356 replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args

288357 replaceSaturatedTypeSynonym t = t

289358

359+-- |

360+-- Replace a type synonym and its arguments with the aliased type

361+--

290362expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type

291363expandTypeSynonym name args = do

292364 env <- getEnv

@@ -295,12 +367,21 @@ expandTypeSynonym name args = do

295367 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body

296368 Nothing -> error "Type synonym was not defined"

297369

370+-- |

371+-- Ensure a set of property names and value does not contain duplicate labels

372+--

298373ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()

299374ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps

300375

376+-- |

377+-- Infer a type for a value, rethrowing any error to provide a more useful error message

378+--

301379infer :: Value -> Subst Value

302380infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val

303381

382+-- |

383+-- Infer a type for a value

384+--

304385infer' :: Value -> Subst Value

305386infer' v@(NumericLiteral _) = return $ TypedValue True v Number

306387infer' v@(StringLiteral _) = return $ TypedValue True v String

@@ -399,6 +480,9 @@ infer' (TypedValue checkType val ty) = do

399480 return $ TypedValue True val' ty

400481infer' _ = error "Invalid argument to infer"

401482

483+-- |

484+-- Infer the type of a property inside a record with a given type

485+--

402486inferProperty :: Type -> String -> Subst (Maybe Type)

403487inferProperty (Object row) prop = do

404488 let (props, _) = rowToList row

@@ -411,6 +495,9 @@ inferProperty (ForAll ident ty) prop = do

411495 inferProperty replaced prop

412496inferProperty _ _ = return Nothing

413497

498+-- |

499+-- Infer the type of a unary operator application

500+--

414501inferUnary :: UnaryOperator -> Value -> Subst Value

415502inferUnary op (TypedValue _ val valTy) =

416503 case fromMaybe (error "Invalid operator") $ lookup op unaryOps of

@@ -419,6 +506,9 @@ inferUnary op (TypedValue _ val valTy) =

419506 return $ TypedValue True (Unary op val) resTy

420507inferUnary _ _ = error "Invalid arguments to inferUnary"

421508

509+-- |

510+-- Check the type of a unary operator application

511+--

422512checkUnary :: UnaryOperator -> Value -> Type -> Subst Value

423513checkUnary op val res =

424514 case fromMaybe (error "Invalid operator") $ lookup op unaryOps of

@@ -427,12 +517,18 @@ checkUnary op val res =

427517 val' <- check val valTy

428518 return $ Unary op val'

429519

520+-- |

521+-- Built-in unary operators

522+--

430523unaryOps :: [(UnaryOperator, (Type, Type))]

431524unaryOps = [ (Negate, (Number, Number))

432525 , (Not, (Boolean, Boolean))

433526 , (BitwiseNot, (Number, Number))

434527 ]

435528

529+-- |

530+-- Infer the type of a binary operator application

531+--

436532inferBinary :: BinaryOperator -> Value -> Value -> Subst Value

437533inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do

438534 leftTy ~~ rightTy

@@ -445,6 +541,9 @@ inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =

445541 return $ TypedValue True (Binary op left right) resTy

446542inferBinary _ _ _ = error "Invalid arguments to inferBinary"

447543

544+-- |

545+-- Check the type of a binary operator application

546+--

448547checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst Value

449548checkBinary op left right res | isEqualityTest op = do

450549 res ~~ Boolean

@@ -460,11 +559,17 @@ checkBinary op left right res =

460559 right' <- check right valTy

461560 return $ Binary op left' right'

462561

562+-- |

563+-- Check if a @BinaryOperator@ is an equality test

564+--

463565isEqualityTest :: BinaryOperator -> Bool

464566isEqualityTest EqualTo = True

465567isEqualityTest NotEqualTo = True

466568isEqualityTest _ = False

467569

570+-- |

571+-- Built-in binary operators

572+--

468573binaryOps :: [(BinaryOperator, (Type, Type))]

469574binaryOps = [ (Add, (Number, Number))

470575 , (Subtract, (Number, Number))

@@ -486,6 +591,9 @@ binaryOps = [ (Add, (Number, Number))

486591 , (GreaterThanOrEqualTo, (Number, Boolean))

487592 ]

488593

594+-- |

595+-- Infer the types of variables brought into scope by a binder

596+--

489597inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)

490598inferBinder _ NullBinder = return M.empty

491599inferBinder val (StringBinder _) = val ~~ String >> return M.empty

@@ -541,6 +649,9 @@ inferBinder val (NamedBinder name binder) = do

541649 m <- inferBinder val binder

542650 return $ M.insert name val m

543651

652+-- |

653+-- Check the types of the return values in a set of binders in a case statement

654+--

544655checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst [([Binder], Maybe Guard, Value)]

545656checkBinders _ _ [] = return []

546657checkBinders nvals ret ((binders, grd, val):bs) = do

@@ -556,6 +667,9 @@ checkBinders nvals ret ((binders, grd, val):bs) = do

556667 rs <- checkBinders nvals ret bs

557668 return $ r : rs

558669

670+-- |

671+-- Check that a local variable name is not already used

672+--

559673assignVariable :: Ident -> Subst ()

560674assignVariable name = do

561675 env <- checkEnv <$> get

@@ -564,6 +678,10 @@ assignVariable name = do

564678 Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."

565679 _ -> return ()

566680

681+-- |

682+-- Check the type of the return values of a statement, returning whether or not the statement returns on

683+-- all code paths

684+--

567685checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type, Statement)

568686checkStatement mass _ (VariableIntroduction name val) = do

569687 assignVariable name

@@ -593,6 +711,9 @@ checkStatement mass ret (Return val) = do

593711 val' <- check val ret

594712 return (True, mass, Return val')

595713

714+-- |

715+-- Check the type of an if-then-else statement

716+--

596717checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst (Bool, IfStatement)

597718checkIfStatement mass ret (IfStatement val thens Nothing) = do

598719 val' <- check val Boolean

@@ -604,12 +725,18 @@ checkIfStatement mass ret (IfStatement val thens (Just elses)) = do

604725 (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses

605726 return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))

606727

728+-- |

729+-- Check the type of an else statement

730+--

607731checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst (Bool, ElseStatement)

608732checkElseStatement mass ret (Else elses) = do

609733 (allCodePathsReturn, _, elses') <- checkBlock mass ret elses

610734 return (allCodePathsReturn, Else elses')

611735checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement mass ret ifst

612736

737+-- |

738+-- Check the type of the return value of a block of statements

739+--

613740checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type, [Statement])

614741checkBlock mass _ [] = return (False, mass, [])

615742checkBlock mass ret (s:ss) = do

@@ -622,11 +749,17 @@ checkBlock mass ret (s:ss) = do

622749 (b, m, ss'') <- checkBlock mass1 ret ss'

623750 return (b, m, s':ss'')

624751

752+-- |

753+-- Skolemize a type variable by replacing its instances with fresh skolem constants

754+--

625755skolemize :: String -> Type -> Subst Type

626756skolemize ident ty = do

627757 tsk <- Skolem <$> fresh'

628758 return $ replaceTypeVars ident tsk ty

629759

760+-- |

761+-- Check the type of a value, rethrowing errors to provide a better error message

762+--

630763check :: Value -> Type -> Subst Value

631764check val ty = rethrow errorMessage $ check' val ty

632765 where

@@ -638,6 +771,9 @@ check val ty = rethrow errorMessage $ check' val ty

638771 ":\n" ++

639772 msg

640773

774+-- |

775+-- Check the type of a value

776+--

641777check' :: Value -> Type -> Subst Value

642778check' val (ForAll idents ty) = do

643779 sk <- skolemize idents ty

@@ -736,6 +872,11 @@ check' val (SaturatedTypeSynonym name args) = do

736872 check val ty

737873check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty

738874

875+-- |

876+-- Check the type of a collection of named record fields

877+--

878+-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.

879+--

739880checkProperties :: [(String, Value)] -> Type -> Bool -> Subst [(String, Value)]

740881checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

741882 go [] [] REmpty = return []

@@ -765,6 +906,9 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where

765906 return $ (p, v') : ps''

766907 go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)

767908

909+-- |

910+-- Check the type of a function application, rethrowing errors to provide a better error message

911+--

768912checkFunctionApplication :: Value -> Type -> [Value] -> Type -> Subst Value

769913checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret

770914 where

@@ -773,6 +917,9 @@ checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunction

773917 ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)

774918 ++ ":\n" ++ msg

775919

920+-- |

921+-- Check the type of a function application

922+--

776923checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> Subst Value

777924checkFunctionApplication' fn (Function argTys retTy) args ret = do

778925 guardWith "Incorrect number of function arguments" (length args == length argTys)

@@ -800,12 +947,27 @@ checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of

800947 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)

801948 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."

802949

950+-- |

951+-- Check whether one type subsumes another, rethrowing errors to provide a better error message

952+--

803953subsumes :: Type -> Type -> Subst ()

804−subsumes (ForAll ident ty1) ty2 = do

954+subsumes ty1 ty2 = rethrow errorMessage $ subsumes' ty1 ty2

955+ where

956+ errorMessage msg = "Error checking that type "

957+ ++ prettyPrintType ty1

958+ ++ " subsumes type "

959+ ++ prettyPrintType ty2

960+ ++ ":\n" ++ msg

961+

962+-- |

963+-- Check whether one type subsumes another

964+--

965+subsumes' :: Type -> Type -> Subst ()

966+subsumes' (ForAll ident ty1) ty2 = do

805967 replaced <- replaceVarWithUnknown ident ty1

806968 replaced `subsumes` ty2

807−subsumes (Function args1 ret1) (Function args2 ret2) = do

969+subsumes' (Function args1 ret1) (Function args2 ret2) = do

808970 zipWithM_ subsumes args2 args1

809971 ret1 `subsumes` ret2

810−subsumes ty1 ty2 = ty1 ~~ ty2

972+subsumes' ty1 ty2 = ty1 ~~ ty2

811973

src/Language/PureScript/Types.hs+73

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Data types for types

1213--

1314-----------------------------------------------------------------------------

1415

@@ -22,37 +23,100 @@ import Data.Generics (mkT, mkQ, everywhereBut)

2223import Language.PureScript.Names

2324import Language.PureScript.Unknown (Unknown(..))

2425

26+-- |

27+-- The type of types

28+--

2529data Type

30+ -- |

31+ -- A unification variable of type Type

32+ --

2633 = TUnknown (Unknown Type)

34+ -- |

35+ -- Javascript numbers

36+ --

2737 | Number

38+ -- |

39+ -- Javascript strings

40+ --

2841 | String

42+ -- |

43+ -- Javascript booleans

44+ --

2945 | Boolean

46+ -- |

47+ -- Javascript array type constructor

48+ --

3049 | Array

50+ -- |

51+ -- Records, parameterized by a row of types

52+ --

3153 | Object Type

54+ -- |

55+ -- A function, with zero or more arguments

56+ --

3257 | Function [Type] Type

58+ -- |

59+ -- A named type variable

60+ --

3361 | TypeVar String

62+ -- |

63+ -- A type constructor

64+ --

3465 | TypeConstructor (Qualified ProperName)

66+ -- |

67+ -- A type application

68+ --

3569 | TypeApp Type Type

70+ -- |

71+ -- A type synonym which is \"saturated\", i.e. fully applied

72+ --

3673 | SaturatedTypeSynonym (Qualified ProperName) [Type]

74+ -- |

75+ -- Forall quantifier

76+ --

3777 | ForAll String Type

78+ -- |

79+ -- A type with a set of type class constraints

80+ --

3881 | ConstrainedType [(Qualified ProperName, Type)] Type

82+ -- |

83+ -- A skolem constant

84+ --

3985 | Skolem Int

86+ -- |

87+ -- An empty row

88+ --

4089 | REmpty

90+ -- |

91+ -- A non-empty row

92+ --

4193 | RCons String Type Type deriving (Show, Eq, Data, Typeable)

4294

95+-- |

96+-- Convert a row to a list of pairs of labels and types

97+--

4398rowToList :: Type -> ([(String, Type)], Type)

4499rowToList (RCons name ty row) = let (tys, rest) = rowToList row

45100 in ((name, ty):tys, rest)

46101rowToList r = ([], r)

47102

103+-- |

104+-- Convert a list of labels and types to a row

105+--

48106rowFromList :: ([(String, Type)], Type) -> Type

49107rowFromList ([], r) = r

50108rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))

51109

110+-- |

111+-- Check whether a type is a monotype

112+--

52113isMonoType :: Type -> Bool

53114isMonoType (ForAll _ _) = False

54115isMonoType ty = isPolyType ty

55116

117+-- |

118+-- Check whather a type is a valid polytype

119+--

56120isPolyType :: Type -> Bool

57121isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)

58122isPolyType (Function args ret) = all isPolyType args && isPolyType ret

@@ -61,12 +125,21 @@ isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args

61125isPolyType (ForAll _ ty) = isPolyType ty

62126isPolyType _ = True

63127

128+-- |

129+-- Universally quantify a type

130+--

64131mkForAll :: [String] -> Type -> Type

65132mkForAll = flip . foldl . flip $ ForAll

66133

134+-- |

135+-- The empty record type

136+--

67137unit :: Type

68138unit = Object REmpty

69139

140+-- |

141+-- Replace a type variable, taking into account variable shadowing

142+--

70143replaceTypeVars :: (Data d) => String -> Type -> d -> d

71144replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)

72145 where

src/Language/PureScript/Unknown.hs+4

@@ -9,6 +9,7 @@

99-- Portability :

1010--

1111-- |

12+-- Data type for unification variables

1213--

1314-----------------------------------------------------------------------------

1415

@@ -18,6 +19,9 @@ module Language.PureScript.Unknown where

1819

1920import Data.Data

2021

22+-- |

23+-- The type of typed unification variables

24+--

2125newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)

2226

2327