git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Starting work on code comments
cb57250Phil Freeman
src/Data/Generics/Extras.hs+4
compare with golang
unifiedsplit
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Additional SYB combinators
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -18,6 +19,9 @@ module Data.Generics.Extras where
18
19
19import Data.Data
20import Data.Data
20
21
22+-- |
23+-- Apply a top-down monadic transformation everywhere
24+--
21everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d
25everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d
22everywhereM' f x = do
26everywhereM' f x = do
23 y <- f x
27 y <- f x
src/Language/PureScript.hs+18
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- The main compiler module
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -32,6 +33,23 @@ import Control.Monad (when, forM)
32import Control.Applicative ((<$>))
33import Control.Applicative ((<$>))
33import qualified Data.Map as M
34import qualified Data.Map as M
34
35
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+--
35compile :: Options -> [Module] -> Either String (String, String, Environment)
53compile :: Options -> [Module] -> Either String (String, String, Environment)
36compile opts ms = do
54compile opts ms = do
37 sorted <- sortModules ms
55 sorted <- sortModules ms
src/Language/PureScript/CodeGen.hs+7
@@ -9,6 +9,13 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
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
12--
19--
13-----------------------------------------------------------------------------
20-----------------------------------------------------------------------------
14
21
src/Language/PureScript/Declarations.hs+85−1
@@ -8,7 +8,7 @@
8-- Stability : experimental
8-- Stability : experimental
9-- Portability :
9-- Portability :
10--
10--
11−-- |
11+-- | Data types for modules and declarations
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
@@ -24,59 +24,143 @@ import Language.PureScript.CodeGen.JS.AST
24
24
25import qualified Data.Data as D
25import qualified Data.Data as D
26
26
27+-- |
28+-- A precedence level for an infix operator
29+--
27type Precedence = Integer
30type Precedence = Integer
28
31
32+-- |
33+-- Associativity for infix operators
34+--
29data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
35data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable)
30
36
37+-- |
38+-- Fixity data for infix operators
39+--
31data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
40data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
32
41
42+-- |
43+-- A module declaration, consisting of a module name and a list of declarations
44+--
33data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
45data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable)
34
46
47+-- |
48+-- The type of a foreign import
49+--
35data ForeignImportType
50data ForeignImportType
51+ -- |
52+ -- A regular foreign import
53+ --
36 = ForeignImport
54 = ForeignImport
55+ -- |
56+ -- A type class dictionary import, generated during desugaring of type class declarations
57+ --
37 | TypeClassDictionaryImport
58 | TypeClassDictionaryImport
59+ -- |
60+ -- A type class dictionary member accessor import, generated during desugaring of type class declarations
61+ --
38 | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)
62 | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable)
39
63
64+-- |
65+-- The data type of declarations
66+--
40data Declaration
67data Declaration
68+ -- |
69+ -- A data type declaration (name, arguments, data constructors)
70+ --
41 = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
71 = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]
72+ -- |
73+ -- A minimal mutually recursive set of data type declarations
74+ --
42 | DataBindingGroupDeclaration [Declaration]
75 | DataBindingGroupDeclaration [Declaration]
76+ -- |
77+ -- A type synonym declaration (name, arguments, type)
78+ --
43 | TypeSynonymDeclaration ProperName [String] Type
79 | TypeSynonymDeclaration ProperName [String] Type
80+ -- |
81+ -- A type declaration for a value (name, ty)
82+ --
44 | TypeDeclaration Ident Type
83 | TypeDeclaration Ident Type
84+ -- |
85+ -- A value declaration (name, top-level binders, optional guard, value)
86+ --
45 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
87 | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value
88+ -- |
89+ -- A minimal mutually recursive set of value declarations
90+ --
46 | BindingGroupDeclaration [(Ident, Value)]
91 | BindingGroupDeclaration [(Ident, Value)]
92+ -- |
93+ -- A foreign import declaration (type, name, optional inline Javascript, type)
94+ --
47 | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
95 | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
96+ -- |
97+ -- A data type foreign import (name, kind)
98+ --
48 | ExternDataDeclaration ProperName Kind
99 | ExternDataDeclaration ProperName Kind
100+ -- |
101+ -- A fixity declaration (fixity data, operator name)
102+ --
49 | FixityDeclaration Fixity String
103 | FixityDeclaration Fixity String
104+ -- |
105+ -- A module import (module name, optional set of identifiers to import)
106+ --
50 | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
107 | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])
108+ -- |
109+ -- A type class declaration (name, argument, member declarations)
110+ --
51 | TypeClassDeclaration ProperName String [Declaration]
111 | TypeClassDeclaration ProperName String [Declaration]
112+ -- |
113+ -- A type instance declaration (dependencies, class name, instance type, member declarations)
114+ --
52 | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]
115 | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration]
53 deriving (Show, D.Data, D.Typeable)
116 deriving (Show, D.Data, D.Typeable)
54
117
118+-- |
119+-- Test if a declaration is a value declaration
120+--
55isValueDecl :: Declaration -> Bool
121isValueDecl :: Declaration -> Bool
56isValueDecl (ValueDeclaration _ _ _ _) = True
122isValueDecl (ValueDeclaration _ _ _ _) = True
57isValueDecl _ = False
123isValueDecl _ = False
58
124
125+-- |
126+-- Test if a declaration is a data type or type synonym declaration
127+--
59isDataDecl :: Declaration -> Bool
128isDataDecl :: Declaration -> Bool
60isDataDecl (DataDeclaration _ _ _) = True
129isDataDecl (DataDeclaration _ _ _) = True
61isDataDecl (TypeSynonymDeclaration _ _ _) = True
130isDataDecl (TypeSynonymDeclaration _ _ _) = True
62isDataDecl _ = False
131isDataDecl _ = False
63
132
133+-- |
134+-- Test if a declaration is a module import
135+--
64isImportDecl :: Declaration -> Bool
136isImportDecl :: Declaration -> Bool
65isImportDecl (ImportDeclaration _ _) = True
137isImportDecl (ImportDeclaration _ _) = True
66isImportDecl _ = False
138isImportDecl _ = False
67
139
140+-- |
141+-- Test if a declaration is a data type foreign import
142+--
68isExternDataDecl :: Declaration -> Bool
143isExternDataDecl :: Declaration -> Bool
69isExternDataDecl (ExternDataDeclaration _ _) = True
144isExternDataDecl (ExternDataDeclaration _ _) = True
70isExternDataDecl _ = False
145isExternDataDecl _ = False
71
146
147+-- |
148+-- Test if a declaration is a fixity declaration
149+--
72isFixityDecl :: Declaration -> Bool
150isFixityDecl :: Declaration -> Bool
73isFixityDecl (FixityDeclaration _ _) = True
151isFixityDecl (FixityDeclaration _ _) = True
74isFixityDecl _ = False
152isFixityDecl _ = False
75
153
154+-- |
155+-- Test if a declaration is a foreign import
156+--
76isExternDecl :: Declaration -> Bool
157isExternDecl :: Declaration -> Bool
77isExternDecl (ExternDeclaration _ _ _ _) = True
158isExternDecl (ExternDeclaration _ _ _ _) = True
78isExternDecl _ = False
159isExternDecl _ = False
79
160
161+-- |
162+-- Test if a declaration is a type class or instance declaration
163+--
80isTypeClassDeclaration :: Declaration -> Bool
164isTypeClassDeclaration :: Declaration -> Bool
81isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True
165isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True
82isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True
166isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True
src/Language/PureScript/Kinds.hs+18
@@ -19,9 +19,27 @@ module Language.PureScript.Kinds where
19import Data.Data
19import Data.Data
20import Language.PureScript.Unknown
20import Language.PureScript.Unknown
21
21
22+-- |
23+-- The data type of kinds
24+--
22data Kind
25data Kind
26+ -- |
27+ -- Unification variable of type Kind
28+ --
23 = KUnknown (Unknown Kind)
29 = KUnknown (Unknown Kind)
30+ -- |
31+ -- The kind of types
32+ --
24 | Star
33 | Star
34+ -- |
35+ -- The kind of effects
36+ --
25 | Bang
37 | Bang
38+ -- |
39+ -- Kinds for labelled, unordered rows without duplicates
40+ --
26 | Row Kind
41 | Row Kind
42+ -- |
43+ -- Function kinds
44+ --
27 | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
45 | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
src/Language/PureScript/ModuleDependencies.hs+12−8
@@ -8,7 +8,7 @@
8-- Stability : experimental
8-- Stability : experimental
9-- Portability :
9-- Portability :
10--
10--
11−-- |
11+-- | Provides the ability to sort modules based on module dependencies
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
@@ -27,18 +27,19 @@ import Language.PureScript.Names
27import Language.PureScript.Values
27import Language.PureScript.Values
28import Language.PureScript.Types
28import Language.PureScript.Types
29
29
30+-- |
31+-- Sort a collection of modules based on module dependencies.
32+--
33+-- Reports an error if the module graph contains a cycle.
34+--
30sortModules :: [Module] -> Either String [Module]
35sortModules :: [Module] -> Either String [Module]
31sortModules ms = do
36sortModules ms = do
32 let verts = map (\m -> (m, getModuleName m, usedModules m)) ms
37 let verts = map (\m -> (m, getModuleName m, usedModules m)) ms
33 mapM toModule $ stronglyConnComp verts
38 mapM toModule $ stronglyConnComp verts
34
39
35−collapseBindingGroups :: [Declaration] -> [Declaration]
40+-- |
36−collapseBindingGroups ds = concatMap go ds
41+-- Calculate a list of used modules based on explicit imports and qualified names
37− where
42+--
38− go (DataBindingGroupDeclaration ds) = ds
39− go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds
40− go other = [other]
41−
42usedModules :: (Data d) => d -> [ProperName]
43usedModules :: (Data d) => d -> [ProperName]
43usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)
44usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports)
44 where
45 where
@@ -55,6 +56,9 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp
55getModuleName :: Module -> ProperName
56getModuleName :: Module -> ProperName
56getModuleName (Module pn _) = pn
57getModuleName (Module pn _) = pn
57
58
59+-- |
60+-- Convert a strongly connected component of the module graph to a module
61+--
58toModule :: SCC Module -> Either String Module
62toModule :: SCC Module -> Either String Module
59toModule (AcyclicSCC m) = return m
63toModule (AcyclicSCC m) = return m
60toModule (CyclicSCC [m]) = return m
64toModule (CyclicSCC [m]) = return m
src/Language/PureScript/Names.hs+25−1
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Data types for names
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -18,28 +19,51 @@ module Language.PureScript.Names where
18
19
19import Data.Data
20import Data.Data
20
21
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+ --
21−data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)
33+ | Op String deriving (Eq, Ord, Data, Typeable)
22
34
23instance Show Ident where
35instance Show Ident where
24 show (Ident s) = s
36 show (Ident s) = s
25 show (Op op) = '(':op ++ ")"
37 show (Op op) = '(':op ++ ")"
26
38
39+-- |
40+-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
41+--
27newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
42newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
28
43
29instance Show ProperName where
44instance Show ProperName where
30 show = runProperName
45 show = runProperName
31
46
47+-- |
48+-- Module names
49+--
32data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)
50data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable)
33
51
34instance Show ModuleName where
52instance Show ModuleName where
35 show (ModuleName name) = show name
53 show (ModuleName name) = show name
36
54
55+-- |
56+-- A qualified name, i.e. a name with an optional module name
57+--
37data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)
58data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable)
38
59
39instance (Show a) => Show (Qualified a) where
60instance (Show a) => Show (Qualified a) where
40 show (Qualified Nothing a) = show a
61 show (Qualified Nothing a) = show a
41 show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a
62 show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a
42
63
64+-- |
65+-- Provide a default module name, if a name is unqualified
66+--
43qualify :: ModuleName -> Qualified a -> (ModuleName, a)
67qualify :: ModuleName -> Qualified a -> (ModuleName, a)
44qualify m (Qualified Nothing a) = (m, a)
68qualify m (Qualified Nothing a) = (m, a)
45qualify _ (Qualified (Just m) a) = (m, a)
69qualify _ (Qualified (Just m) a) = (m, a)
src/Language/PureScript/Options.hs+21−2
@@ -9,17 +9,36 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- The data type of compiler options
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
15module Language.PureScript.Options where
16module Language.PureScript.Options where
16
17
18+-- |
19+-- The data type of compiler options
20+--
17−data Options = Options
21+data Options = Options {
22+ -- |
23+ -- Perform tail-call elimination
24+ --
18− { optionsTco :: Bool
25+ optionsTco :: Bool
26+ -- |
27+ -- Perform type checks at runtime
28+ --
19 , optionsPerformRuntimeTypeChecks :: Bool
29 , optionsPerformRuntimeTypeChecks :: Bool
30+ -- |
31+ -- Inline calls to ret and bind for the Eff monad
32+ --
20 , optionsMagicDo :: Bool
33 , optionsMagicDo :: Bool
34+ -- |
35+ -- Check the type of Main.main and generate its code
36+ --
21 , optionsRunMain :: Bool
37 , optionsRunMain :: Bool
22 } deriving Show
38 } deriving Show
23
39
40+-- |
41+-- Default compiler options
42+--
24defaultOptions :: Options
43defaultOptions :: Options
25defaultOptions = Options False False False False
44defaultOptions = Options False False False False
src/Language/PureScript/Parser.hs+13
@@ -9,6 +9,19 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
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
12--
25--
13-----------------------------------------------------------------------------
26-----------------------------------------------------------------------------
14
27
src/Language/PureScript/Pretty.hs+9
@@ -9,6 +9,15 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
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
12--
21--
13-----------------------------------------------------------------------------
22-----------------------------------------------------------------------------
14
23
src/Language/PureScript/Pretty/Common.hs+56
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Common pretty-printing utility functions
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -25,6 +26,13 @@ import Control.Arrow ((***), (<+>))
25
26
26import Language.PureScript.Names
27import Language.PureScript.Names
27
28
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+--
28identToJs :: Ident -> String
36identToJs :: Ident -> String
29identToJs (Ident name) = concatMap identCharToString name
37identToJs (Ident name) = concatMap identCharToString name
30identToJs (Op op) = concatMap identCharToString op
38identToJs (Op op) = concatMap identCharToString op
@@ -34,43 +42,91 @@ identCharToString c | isAlphaNum c = [c]
34identCharToString '_' = "_"
42identCharToString '_' = "_"
35identCharToString c = '$' : show (ord c)
43identCharToString c = '$' : show (ord c)
36
44
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+--
37newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
50newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus)
38
51
39instance Functor (Pattern u a) where
52instance Functor (Pattern u a) where
40 fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
53 fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p
41
54
55+-- |
56+-- Run a pattern with an input and initial user state
57+--
58+-- Returns Nothing if the pattern fails to match
59+--
42pattern :: Pattern u a b -> u -> a -> Maybe b
60pattern :: Pattern u a b -> u -> a -> Maybe b
43pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
61pattern p u = flip evalStateT u . A.runKleisli (runPattern p)
44
62
63+-- |
64+-- Construct a pattern from a function
65+--
45mkPattern :: (a -> Maybe b) -> Pattern u a b
66mkPattern :: (a -> Maybe b) -> Pattern u a b
46mkPattern f = Pattern $ A.Kleisli (lift . f)
67mkPattern f = Pattern $ A.Kleisli (lift . f)
47
68
69+-- |
70+-- Construct a pattern from a stateful function
71+--
48mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
72mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b
49mkPattern' = Pattern . A.Kleisli
73mkPattern' = Pattern . A.Kleisli
50
74
75+-- |
76+-- Wrap a string in parentheses
77+--
51parens :: String -> String
78parens :: String -> String
52parens s = ('(':s) ++ ")"
79parens s = ('(':s) ++ ")"
53
80
81+-- |
82+-- Construct a pattern which recursively matches on the left-hand-side
83+--
54chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
84chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
55chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
85chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f)
56
86
87+-- |
88+-- Construct a pattern which recursively matches on the right-hand side
89+--
57chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
90chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r
58chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
91chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f)
59
92
93+-- |
94+-- Construct a pattern which recursively matches on one-side of a tuple
95+--
60wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
96wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r
61wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
97wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f)
62
98
99+-- |
100+-- Construct a pattern which matches a part of a tuple
101+--
63split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
102split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r
64split s f = s >>> A.arr (uncurry f)
103split s f = s >>> A.arr (uncurry f)
65
104
105+-- |
106+-- A table of operators
107+--
66data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
108data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] }
67
109
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+--
68data Operator u a r where
121data Operator u a r where
69 AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
122 AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
70 AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
123 AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r
71 Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
124 Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r
72 Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r
125 Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r
73
126
127+-- |
128+-- Build a pretty printer from an operator table and an indecomposable pattern
129+--
74buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r
130buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r
75buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
131buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op ->
76 case op of
132 case op of
src/Language/PureScript/Pretty/JS.hs+19
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Pretty printer for the Javascript AST
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -30,9 +31,15 @@ import Control.Monad.State
30
31
31newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
32newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
32
33
34+-- |
35+-- Number of characters per identation level
36+--
33blockIndent :: Int
37blockIndent :: Int
34blockIndent = 4
38blockIndent = 4
35
39
40+-- |
41+-- Pretty print with a new indentation level
42+--
36withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
43withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
37withIndent action = do
44withIndent action = do
38 modify $ \st -> st { indent = indent st + blockIndent }
45 modify $ \st -> st { indent = indent st + blockIndent }
@@ -40,6 +47,9 @@ withIndent action = do
40 modify $ \st -> st { indent = indent st - blockIndent }
47 modify $ \st -> st { indent = indent st - blockIndent }
41 return result
48 return result
42
49
50+-- |
51+-- Get the current indentation level
52+--
43currentIndent :: StateT PrinterState Maybe String
53currentIndent :: StateT PrinterState Maybe String
44currentIndent = do
54currentIndent = do
45 current <- get
55 current <- get
@@ -187,15 +197,24 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
187 match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
197 match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
188 match' _ = Nothing
198 match' _ = Nothing
189
199
200+-- |
201+-- Generate a pretty-printed string representing a Javascript expression
202+--
190prettyPrintJS1 :: JS -> String
203prettyPrintJS1 :: JS -> String
191prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
204prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
192
205
206+-- |
207+-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
208+--
193prettyPrintJS :: [JS] -> String
209prettyPrintJS :: [JS] -> String
194prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do
210prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do
195 jss <- forM sts prettyPrintJS'
211 jss <- forM sts prettyPrintJS'
196 indentString <- currentIndent
212 indentString <- currentIndent
197 return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss
213 return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss
198
214
215+-- |
216+-- Generate an indented, pretty-printed string representing a Javascript expression
217+--
199prettyPrintJS' :: JS -> StateT PrinterState Maybe String
218prettyPrintJS' :: JS -> StateT PrinterState Maybe String
200prettyPrintJS' = A.runKleisli $ runPattern matchValue
219prettyPrintJS' = A.runKleisli $ runPattern matchValue
201 where
220 where
src/Language/PureScript/Pretty/Kinds.hs+4
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Pretty printer for kinds
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -43,6 +44,9 @@ funKind = mkPattern match
43 match (FunKind arg ret) = Just (arg, ret)
44 match (FunKind arg ret) = Just (arg, ret)
44 match _ = Nothing
45 match _ = Nothing
45
46
47+-- |
48+-- Generate a pretty-printed string representing a Kind
49+--
46prettyPrintKind :: Kind -> String
50prettyPrintKind :: Kind -> String
47prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
51prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
48 where
52 where
src/Language/PureScript/Pretty/Types.hs+7
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Pretty printer for Types
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -44,6 +45,9 @@ typeLiterals = mkPattern match
44 match row@(RCons _ _ _) = Just $ prettyPrintRow row
45 match row@(RCons _ _ _) = Just $ prettyPrintRow row
45 match _ = Nothing
46 match _ = Nothing
46
47
48+-- |
49+-- Generate a pretty-printed string representing a Row
50+--
47prettyPrintRow :: Type -> String
51prettyPrintRow :: Type -> String
48prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
52prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
49 where
53 where
@@ -77,6 +81,9 @@ function = mkPattern match
77 match (Function args ret) = Just (args, ret)
81 match (Function args ret) = Just (args, ret)
78 match _ = Nothing
82 match _ = Nothing
79
83
84+-- |
85+-- Generate a pretty-printed string representing a Type
86+--
80prettyPrintType :: Type -> String
87prettyPrintType :: Type -> String
81prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()
88prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType ()
82 where
89 where
src/Language/PureScript/Pretty/Values.hs+7
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Pretty printer for values
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -113,6 +114,9 @@ prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val
113prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val
114prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val
114prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val
115prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val
115
116
117+-- |
118+-- Generate a pretty-printed string representing a Value
119+--
116prettyPrintValue :: Value -> String
120prettyPrintValue :: Value -> String
117prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
121prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue ()
118 where
122 where
@@ -170,6 +174,9 @@ prettyPrintBinderAtom = mkPattern match
170 match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
174 match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder
171 match _ = Nothing
175 match _ = Nothing
172
176
177+-- |
178+-- Generate a pretty-printed string representing a Binder
179+--
173prettyPrintBinder :: Binder -> String
180prettyPrintBinder :: Binder -> String
174prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
181prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder ()
175 where
182 where
src/Language/PureScript/Scope.hs+7
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Utility functions for working with names in scope
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -25,6 +26,9 @@ import Language.PureScript.Values
25import Language.PureScript.Names
26import Language.PureScript.Names
26import Language.PureScript.CodeGen.JS.AST
27import Language.PureScript.CodeGen.JS.AST
27
28
29+-- |
30+-- Gather all used names appearing inside a value
31+--
28usedNames :: (Data d) => d -> [Ident]
32usedNames :: (Data d) => d -> [Ident]
29usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val
33usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val
30 where
34 where
@@ -47,6 +51,9 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB
47 namesJS (JSFor name _ _ _) = [name]
51 namesJS (JSFor name _ _ _) = [name]
48 namesJS _ = []
52 namesJS _ = []
49
53
54+-- |
55+-- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@
56+--
50unusedNames :: (Data d) => d -> [Ident]
57unusedNames :: (Data d) => d -> [Ident]
51unusedNames val =
58unusedNames val =
52 let
59 let
src/Language/PureScript/Sugar.hs+16
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Desugaring passes
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -25,6 +26,21 @@ import Language.PureScript.Sugar.TypeDeclarations as S
25import Language.PureScript.Sugar.BindingGroups as S
26import Language.PureScript.Sugar.BindingGroups as S
26import Language.PureScript.Sugar.TypeClasses as S
27import Language.PureScript.Sugar.TypeClasses as S
27
28
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+--
28desugar :: [Module] -> Either String [Module]
44desugar :: [Module] -> Either String [Module]
29desugar = desugarTypeClasses
45desugar = desugarTypeClasses
30 >=> rebracket
46 >=> rebracket
src/Language/PureScript/TypeChecker/Kinds.hs+19
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- This module implements the kind checker
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -57,9 +58,15 @@ instance Unifiable Kind where
57 unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2
58 unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2
58 unknowns _ = []
59 unknowns _ = []
59
60
61+-- |
62+-- Infer the kind of a single type
63+--
60kindOf :: ModuleName -> Type -> Check Kind
64kindOf :: ModuleName -> Type -> Check Kind
61kindOf moduleName ty = fmap (\(k, s) -> apply s k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty
65kindOf moduleName ty = fmap (\(k, s) -> apply s k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty
62
66
67+-- |
68+-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
69+--
63kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
70kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
64kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k)) . runSubst (SubstContext moduleName) $ do
71kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k)) . runSubst (SubstContext moduleName) $ do
65 tyCon <- fresh
72 tyCon <- fresh
@@ -68,6 +75,9 @@ kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k))
68 bindLocalTypeVariables moduleName dict $
75 bindLocalTypeVariables moduleName dict $
69 solveTypes ts kargs tyCon
76 solveTypes ts kargs tyCon
70
77
78+-- |
79+-- Simultaneously infer the kinds of several mutually recursive type constructors
80+--
71kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])
81kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])
72kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName) $ do
82kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName) $ do
73 synVars <- replicateM (length syns) fresh
83 synVars <- replicateM (length syns) fresh
@@ -90,6 +100,9 @@ kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName
90 where
100 where
91 tidyUp ((ks1, ks2), s) = (map starIfUnknown $ apply s ks1, map starIfUnknown $ apply s ks2)
101 tidyUp ((ks1, ks2), s) = (map starIfUnknown $ apply s ks1, map starIfUnknown $ apply s ks2)
92
102
103+-- |
104+-- Solve the set of kind constraints associated with the data constructors for a type constructor
105+--
93solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind
106solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind
94solveTypes ts kargs tyCon = do
107solveTypes ts kargs tyCon = do
95 ks <- mapM infer ts
108 ks <- mapM infer ts
@@ -97,11 +110,17 @@ solveTypes ts kargs tyCon = do
97 forM_ ks $ \k -> k ~~ Star
110 forM_ ks $ \k -> k ~~ Star
98 return tyCon
111 return tyCon
99
112
113+-- |
114+-- Default all unknown kinds to the Star kind of types
115+--
100starIfUnknown :: Kind -> Kind
116starIfUnknown :: Kind -> Kind
101starIfUnknown (KUnknown _) = Star
117starIfUnknown (KUnknown _) = Star
102starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
118starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
103starIfUnknown k = k
119starIfUnknown k = k
104
120
121+-- |
122+-- Infer a kind for a type
123+--
105infer :: Type -> Subst Kind
124infer :: Type -> Subst Kind
106infer Number = return Star
125infer Number = return Star
107infer String = return Star
126infer String = return Star
src/Language/PureScript/TypeChecker/Monad.hs+178−6
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Monads for type checking and type inference and associated data types
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -37,31 +38,91 @@ import Control.Arrow ((***))
37
38
38import qualified Data.Map as M
39import qualified Data.Map as M
39
40
41+-- |
42+-- The type of a name in the @Environment@
43+--
40data NameKind
44data NameKind
45+ -- |
46+ -- A value introduced as a binding in a module
47+ --
41 = Value
48 = Value
49+ -- |
50+ -- A foreign import
51+ --
42 | Extern ForeignImportType
52 | Extern ForeignImportType
53+ -- |
54+ -- An alias for a value in another module, introduced using an import declaration
55+ --
43 | Alias ModuleName Ident
56 | Alias ModuleName Ident
57+ -- |
58+ -- A local name introduced using a lambda abstraction, variable introduction or binder
59+ --
44 | LocalVariable
60 | LocalVariable
61+ -- |
62+ -- A data constructor
63+ --
45 | DataConstructor deriving Show
64 | DataConstructor deriving Show
46
65
66+-- |
67+-- The type of a type declaration
68+--
47data TypeDeclarationKind
69data TypeDeclarationKind
70+ -- |
71+ -- A data constructor
72+ --
48 = Data
73 = Data
74+ -- |
75+ -- A data type foreign import
76+ --
49 | ExternData
77 | ExternData
78+ -- |
79+ -- A type synonym
80+ --
50 | TypeSynonym
81 | TypeSynonym
82+ -- |
83+ -- An alias for a type in another module, introduced using an import declaration
84+ --
51 | DataAlias ModuleName ProperName
85 | DataAlias ModuleName ProperName
86+ -- |
87+ -- A local type name introduced using a forall quantifier
88+ --
52 | LocalTypeVariable deriving Show
89 | LocalTypeVariable deriving Show
53
90
91+-- |
92+-- The @Environment@ defines all values and types which are currently in scope:
93+--
54−data Environment = Environment
94+data Environment = Environment {
95+ -- |
96+ -- Value names currently in scope
97+ --
55− { names :: M.Map (ModuleName, Ident) (Type, NameKind)
98+ names :: M.Map (ModuleName, Ident) (Type, NameKind)
99+ -- |
100+ -- Type names currently in scope
101+ --
56 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
102 , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)
103+ -- |
104+ -- Data constructors currently in scope, along with their associated data type constructors
105+ --
57 , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)
106 , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)
107+ -- |
108+ -- Type synonyms currently in scope
109+ --
58 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
110 , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)
111+ -- |
112+ -- Available type class dictionaries
113+ --
59 , typeClassDictionaries :: [TypeClassDictionaryInScope]
114 , typeClassDictionaries :: [TypeClassDictionaryInScope]
60 } deriving (Show)
115 } deriving (Show)
61
116
117+-- |
118+-- An empty environment with no values and no types defined
119+--
62emptyEnvironment :: Environment
120emptyEnvironment :: Environment
63emptyEnvironment = Environment M.empty M.empty M.empty M.empty []
121emptyEnvironment = Environment M.empty M.empty M.empty M.empty []
64
122
123+-- |
124+-- Temporarily bind a collection of names to values
125+--
65bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a
126bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a
66bindNames newNames action = do
127bindNames newNames action = do
67 orig <- get
128 orig <- get
@@ -70,6 +131,9 @@ bindNames newNames action = do
70 modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
131 modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
71 return a
132 return a
72
133
134+-- |
135+-- Temporarily bind a collection of names to types
136+--
73bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a
137bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a
74bindTypes newNames action = do
138bindTypes newNames action = do
75 orig <- get
139 orig <- get
@@ -78,6 +142,9 @@ bindTypes newNames action = do
78 modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
142 modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
79 return a
143 return a
80
144
145+-- |
146+-- Temporarily make a collection of type class dictionaries available
147+--
81withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
148withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
82withTypeClassDictionaries entries action = do
149withTypeClassDictionaries entries action = do
83 orig <- get
150 orig <- get
@@ -86,17 +153,29 @@ withTypeClassDictionaries entries action = do
86 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
153 modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
87 return a
154 return a
88
155
156+-- |
157+-- Get the currently available list of type class dictionaries
158+--
89getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
159getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
90getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
160getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get
91
161
162+-- |
163+-- Temporarily bind a collection of names to local variables
164+--
92bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a
165bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a
93bindLocalVariables moduleName bindings action =
166bindLocalVariables moduleName bindings action =
94 bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action
167 bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action
95
168
169+-- |
170+-- Temporarily bind a collection of names to local type variables
171+--
96bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
172bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
97bindLocalTypeVariables moduleName bindings action =
173bindLocalTypeVariables moduleName bindings action =
98 bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action
174 bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action
99
175
176+-- |
177+-- Lookup the type of a value by name in the @Environment@
178+--
100lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type
179lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type
101lookupVariable currentModule (Qualified moduleName var) = do
180lookupVariable currentModule (Qualified moduleName var) = do
102 env <- getEnv
181 env <- getEnv
@@ -104,6 +183,9 @@ lookupVariable currentModule (Qualified moduleName var) = do
104 Nothing -> throwError $ show var ++ " is undefined"
183 Nothing -> throwError $ show var ++ " is undefined"
105 Just (ty, _) -> return ty
184 Just (ty, _) -> return ty
106
185
186+-- |
187+-- Lookup the kind of a type by name in the @Environment@
188+--
107lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
189lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind
108lookupTypeVariable currentModule (Qualified moduleName name) = do
190lookupTypeVariable currentModule (Qualified moduleName name) = do
109 env <- getEnv
191 env <- getEnv
@@ -111,63 +193,120 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do
111 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
193 Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined"
112 Just (k, _) -> return k
194 Just (k, _) -> return k
113
195
196+-- |
197+-- Canonicalize an identifier by resolving any aliases introduced by module imports
198+--
114canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)
199canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident)
115canonicalize _ _ (Qualified (Just mn) i) = (mn, i)
200canonicalize _ _ (Qualified (Just mn) i) = (mn, i)
116canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of
201canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of
117 Just (_, Alias mn' i') -> (mn', i')
202 Just (_, Alias mn' i') -> (mn', i')
118 _ -> (mn, i)
203 _ -> (mn, i)
119
204
205+-- |
206+-- Canonicalize a type variable by resolving any aliases introduced by module imports
207+--
120canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
208canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName)
121canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)
209canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm)
122canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of
210canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of
123 Just (_, DataAlias mn' pn') -> (mn', pn')
211 Just (_, DataAlias mn' pn') -> (mn', pn')
124 _ -> (mn, nm)
212 _ -> (mn, nm)
125
213
214+-- |
215+-- State required for type checking:
216+--
126−data CheckState = CheckState { checkEnv :: Environment
217+data CheckState = CheckState {
218+ -- |
219+ -- The current @Environment@
220+ --
221+ checkEnv :: Environment
222+ -- |
223+ -- The next fresh unification variable name
224+ --
127− , checkNextVar :: Int
225+ , checkNextVar :: Int
226+ -- |
227+ -- The next type class dictionary name
228+ --
128− , checkNextDictName :: Int
229+ , checkNextDictName :: Int
129− }
230+ }
130
231
232+-- |
233+-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
234+--
131newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
235newtype Check a = Check { unCheck :: StateT CheckState (Either String) a }
132 deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
236 deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String)
133
237
238+-- |
239+-- Get the current @Environment@
240+--
134getEnv :: (Functor m, MonadState CheckState m) => m Environment
241getEnv :: (Functor m, MonadState CheckState m) => m Environment
135getEnv = checkEnv <$> get
242getEnv = checkEnv <$> get
136
243
244+-- |
245+-- Update the @Environment#
246+--
137putEnv :: (MonadState CheckState m) => Environment -> m ()
247putEnv :: (MonadState CheckState m) => Environment -> m ()
138putEnv env = modify (\s -> s { checkEnv = env })
248putEnv env = modify (\s -> s { checkEnv = env })
139
249
250+-- |
251+-- Modify the @Environment@
252+--
140modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
253modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
141modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
254modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
142
255
256+-- |
257+-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
258+--
143runCheck :: Check a -> Either String (a, Environment)
259runCheck :: Check a -> Either String (a, Environment)
144runCheck c = do
260runCheck c = do
145 (a, s) <- flip runStateT (CheckState emptyEnvironment 0 0) $ unCheck c
261 (a, s) <- flip runStateT (CheckState emptyEnvironment 0 0) $ unCheck c
146 return (a, checkEnv s)
262 return (a, checkEnv s)
147
263
264+-- |
265+-- Make an assertion, failing with an error message
266+--
148guardWith :: (MonadError e m) => e -> Bool -> m ()
267guardWith :: (MonadError e m) => e -> Bool -> m ()
149guardWith _ True = return ()
268guardWith _ True = return ()
150guardWith e False = throwError e
269guardWith e False = throwError e
151
270
271+-- |
272+-- Rethrow an error with a more detailed error message in the case of failure
273+--
152rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
274rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
153rethrow f = flip catchError $ \e -> throwError (f e)
275rethrow f = flip catchError $ \e -> throwError (f e)
154
276
277+-- |
278+-- Generate new type class dictionary name
279+--
155freshDictionaryName :: Check Int
280freshDictionaryName :: Check Int
156freshDictionaryName = do
281freshDictionaryName = do
157 n <- checkNextDictName <$> get
282 n <- checkNextDictName <$> get
158 modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
283 modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
159 return n
284 return n
160
285
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+--
161newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
290newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t }
162
291
163instance Monoid Substitution where
292instance Monoid Substitution where
164 mempty = Substitution unknown
293 mempty = Substitution unknown
165 s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u))
294 s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u))
166
295
296+-- |
297+-- State for the substitution monad, which contains the current substitution
298+--
167data SubstState = SubstState { substSubst :: Substitution }
299data SubstState = SubstState { substSubst :: Substitution }
168
300
301+-- |
302+-- Configuration for the substitution monad, constaining the current module
303+--
169newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)
304newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show)
170
305
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+--
171newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }
310newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a }
172 deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)
311 deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext)
173
312
@@ -177,28 +316,46 @@ instance MonadState CheckState Subst where
177
316
178deriving instance MonadError String Subst
317deriving instance MonadError String Subst
179
318
319+-- |
320+-- Lift a computation in the @Check@ monad into the substitution monad.
321+--
180liftCheck :: Check a -> Subst a
322liftCheck :: Check a -> Subst a
181liftCheck = Subst . lift . lift
323liftCheck = Subst . lift . lift
182
324
325+-- |
326+-- Get the current substitution monad state
327+--
183getSubstState :: Subst SubstState
328getSubstState :: Subst SubstState
184getSubstState = Subst . lift $ get
329getSubstState = Subst . lift $ get
185
330
331+-- |
332+-- Run a computation in the substitution monad, generating a return value and the final substitution.
333+--
186runSubst :: SubstContext -> Subst a -> Check (a, Substitution)
334runSubst :: SubstContext -> Subst a -> Check (a, Substitution)
187runSubst context subst = do
335runSubst context subst = do
188 (a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst
336 (a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst
189 return (a, substSubst s)
337 return (a, substSubst s)
190
338
339+-- |
340+-- Generate a substitution from a substitution function for a single type
341+--
191substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
342substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution
192substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do
343substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do
193 u1 <- cast u
344 u1 <- cast u
194 cast (f u1)
345 cast (f u1)
195
346
347+-- |
348+-- Substitute a single unification variable
349+--
196substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution
350substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution
197substituteOne u t = substituteWith $ \u1 ->
351substituteOne u t = substituteWith $ \u1 ->
198 case u1 of
352 case u1 of
199 u2 | u2 == u -> t
353 u2 | u2 == u -> t
200 | otherwise -> unknown u2
354 | otherwise -> unknown u2
201
355
356+-- |
357+-- Replace a unification variable with the specified value in the current substitution
358+--
202replace :: (Unifiable t) => Unknown t -> t -> Subst ()
359replace :: (Unifiable t) => Unknown t -> t -> Subst ()
203replace u t' = do
360replace u t' = do
204 sub <- substSubst <$> Subst get
361 sub <- substSubst <$> Subst get
@@ -210,6 +367,9 @@ replace u t' = do
210 _ -> current ~~ t
367 _ -> current ~~ t
211 Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s }
368 Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s }
212
369
370+-- |
371+-- Identifies types which support unification
372+--
213class (Typeable t, Data t, Show t) => Unifiable t where
373class (Typeable t, Data t, Show t) => Unifiable t where
214 unknown :: Unknown t -> t
374 unknown :: Unknown t -> t
215 (~~) :: t -> t -> Subst ()
375 (~~) :: t -> t -> Subst ()
@@ -224,21 +384,33 @@ instance (Unifiable a) => Unifiable [a] where
224 apply s = map (apply s)
384 apply s = map (apply s)
225 unknowns = concatMap unknowns
385 unknowns = concatMap unknowns
226
386
387+-- |
388+-- Perform the occurs check, to make sure a unification variable does not occur inside a value
389+--
227occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
390occursCheck :: (Unifiable t) => Unknown s -> t -> Subst ()
228occursCheck (Unknown u) t =
391occursCheck (Unknown u) t =
229 case isUnknown t of
392 case isUnknown t of
230 Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)
393 Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t)
231 _ -> return ()
394 _ -> return ()
232
395
396+-- |
397+-- Generate a fresh untyped unification variable
398+--
233fresh' :: Subst Int
399fresh' :: Subst Int
234fresh' = do
400fresh' = do
235 n <- checkNextVar <$> get
401 n <- checkNextVar <$> get
236 modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
402 modify $ \s -> s { checkNextVar = succ (checkNextVar s) }
237 return n
403 return n
238
404
405+-- |
406+-- Generate a fresh unification variable at a specific type
407+--
239fresh :: (Unifiable t) => Subst t
408fresh :: (Unifiable t) => Subst t
240fresh = unknown . Unknown <$> fresh'
409fresh = unknown . Unknown <$> fresh'
241
410
411+-- |
412+-- Replace any unqualified names in a type wit their qualified versionss
413+--
242qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
414qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d
243qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
415qualifyAllUnqualifiedNames mn env = everywhere (mkT go)
244 where
416 where
src/Language/PureScript/TypeChecker/Synonyms.hs+10
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -28,6 +29,9 @@ import Data.Generics.Extras
28import Control.Monad.Writer
29import Control.Monad.Writer
29import Control.Monad.Error
30import Control.Monad.Error
30
31
32+-- |
33+-- Build a type substitution for a type synonym
34+--
31buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)
35buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type)
32buildTypeSubstitution env moduleName name n = go n []
36buildTypeSubstitution env moduleName name n = go n []
33 where
37 where
@@ -37,11 +41,17 @@ buildTypeSubstitution env moduleName name n = go n []
37 go m args (TypeApp f arg) = go (m - 1) (arg:args) f
41 go m args (TypeApp f arg) = go (m - 1) (arg:args) f
38 go _ _ _ = return Nothing
42 go _ _ _ = return Nothing
39
43
44+-- |
45+-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
46+--
40saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d
47saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d
41saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
48saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace)
42 where
49 where
43 replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t
50 replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t
44
51
52+-- |
53+-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
54+--
45saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d
55saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d
46saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
56saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
47
57
src/Language/PureScript/TypeChecker/Types.hs+165−3
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- This module implements the type checker
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -67,6 +68,9 @@ instance Unifiable Type where
67 unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
68 unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
68 unknowns _ = []
69 unknowns _ = []
69
70
71+-- |
72+-- Unify two types, updating the current substitution
73+--
70unifyTypes :: Type -> Type -> Subst ()
74unifyTypes :: Type -> Type -> Subst ()
71unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
75unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
72 unifyTypes' t1 t2
76 unifyTypes' t1 t2
@@ -110,6 +114,13 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
110 unifyTypes' r1 r2@REmpty = unifyRows r1 r2
114 unifyTypes' r1 r2@REmpty = unifyRows r1 r2
111 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
115 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
112
116
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+--
113unifyRows :: Type -> Type -> Subst ()
124unifyRows :: Type -> Type -> Subst ()
114unifyRows r1 r2 =
125unifyRows r1 r2 =
115 let
126 let
@@ -136,9 +147,16 @@ unifyRows r1 r2 =
136 unifyRows' [] (Skolem s1) [] (Skolem s2) | s1 == s2 = return ()
147 unifyRows' [] (Skolem s1) [] (Skolem s2) | s1 == s2 = return ()
137 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
148 unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
138
149
150+-- |
151+-- Ensure type constructors are equal after canonicalization
152+--
139typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
153typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool
140typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env
154typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env
141
155
156+-- |
157+-- Infer the types of multiple mutually-recursive values, and return elaborated values including
158+-- type class dictionaries and type annotations.
159+--
142typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
160typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
143typesOf moduleName vals = do
161typesOf moduleName vals = do
144 tys <- fmap (\(tys, s) -> map (\(ident, (val, ty)) -> (ident, (overTypes (apply s) val, apply s ty))) tys)
162 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
173 return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'
191 return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'
174 , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))
192 , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))
175
193
194+-- |
195+-- Check if a value contains a type annotation
196+--
176isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))
197isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool)))
177isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
198isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType)))
178isTyped (name, value) = (name, (value, Nothing))
199isTyped (name, value) = (name, (value, Nothing))
179
200
201+-- |
202+-- Map a function over type annotations appearing inside a value
203+--
180overTypes :: (Type -> Type) -> Value -> Value
204overTypes :: (Type -> Type) -> Value -> Value
181overTypes f = everywhere (mkT f)
205overTypes f = everywhere (mkT f)
182
206
207+-- |
208+-- Replace type class dictionary placeholders with inferred type class dictionaries
209+--
183replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
210replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value
184replaceTypeClassDictionaries mn = everywhereM (mkM go)
211replaceTypeClassDictionaries mn = everywhereM (mkM go)
185 where
212 where
186 go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
213 go (TypeClassDictionary constraint dicts) = entails mn dicts constraint
187 go other = return other
214 go other = return other
188
215
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+--
189entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value
220entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value
190entails moduleName context goal@(className, ty) = do
221entails moduleName context goal@(className, ty) = do
191 env <- getEnv
222 env <- getEnv
@@ -211,6 +242,10 @@ entails moduleName context goal@(className, ty) = do
211 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
242 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
212 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
243 canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
213
244
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+--
214typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
249typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
215typeHeadsAreEqual _ _ String String = Just []
250typeHeadsAreEqual _ _ String String = Just []
216typeHeadsAreEqual _ _ Number Number = Just []
251typeHeadsAreEqual _ _ Number Number = Just []
@@ -222,6 +257,9 @@ typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <
222typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
257typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
223typeHeadsAreEqual _ _ _ _ = Nothing
258typeHeadsAreEqual _ _ _ _ = Nothing
224
259
260+-- |
261+-- Ensure unsolved unification variables do not escape
262+--
225escapeCheck :: Value -> Type -> Subst ()
263escapeCheck :: Value -> Type -> Subst ()
226escapeCheck value ty = do
264escapeCheck value ty = do
227 subst <- substSubst <$> getSubstState
265 subst <- substSubst <$> getSubstState
@@ -231,12 +269,18 @@ escapeCheck value ty = do
231 let unsolvedUnknowns = nub . unknowns $ apply subst t
269 let unsolvedUnknowns = nub . unknowns $ apply subst t
232 guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
270 guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
233
271
272+-- |
273+-- Find all type annotations occuring inside a value
274+--
234findAllTypes :: Value -> [Type]
275findAllTypes :: Value -> [Type]
235findAllTypes = everything (++) (mkQ [] go)
276findAllTypes = everything (++) (mkQ [] go)
236 where
277 where
237 go (TypedValue _ _ ty) = [ty]
278 go (TypedValue _ _ ty) = [ty]
238 go _ = []
279 go _ = []
239
280
281+-- |
282+-- Ensure skolem variables do not escape their scope
283+--
240skolemEscapeCheck :: Type -> Check ()
284skolemEscapeCheck :: Type -> Check ()
241skolemEscapeCheck ty =
285skolemEscapeCheck ty =
242 case something (mkQ Nothing findSkolems) ty of
286 case something (mkQ Nothing findSkolems) ty of
@@ -246,12 +290,21 @@ skolemEscapeCheck ty =
246 findSkolems (Skolem _) = return ()
290 findSkolems (Skolem _) = return ()
247 findSkolems _ = mzero
291 findSkolems _ = mzero
248
292
293+-- |
294+-- Ensure a row contains no duplicate labels
295+--
249setify :: Type -> Type
296setify :: Type -> Type
250setify = rowFromList . first (M.toList . M.fromList) . rowToList
297setify = rowFromList . first (M.toList . M.fromList) . rowToList
251
298
299+-- |
300+-- \"Setify\" all rows occuring inside a value
301+--
252setifyAll :: (D.Data d) => d -> d
302setifyAll :: (D.Data d) => d -> d
253setifyAll = everywhere (mkT setify)
303setifyAll = everywhere (mkT setify)
254
304
305+-- |
306+-- Replace outermost unsolved unification variables with named type variables
307+--
255varIfUnknown :: Type -> Type
308varIfUnknown :: Type -> Type
256varIfUnknown ty =
309varIfUnknown ty =
257 let unks = nub $ unknowns ty
310 let unks = nub $ unknowns ty
@@ -262,18 +315,31 @@ varIfUnknown ty =
262 typeToVar t = t
315 typeToVar t = t
263 in mkForAll (sort . map toName $ unks) ty'
316 in mkForAll (sort . map toName $ unks) ty'
264
317
318+-- |
319+-- Replace named type variables with types
320+--
265replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
321replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
266replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
322replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
267
323
324+-- |
325+-- Replace named type variables with new unification variables
326+--
268replaceAllVarsWithUnknowns :: Type -> Subst Type
327replaceAllVarsWithUnknowns :: Type -> Subst Type
269replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
328replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
270replaceAllVarsWithUnknowns ty = return ty
329replaceAllVarsWithUnknowns ty = return ty
271
330
331+-- |
332+-- Replace a single type variable with a new unification variable
333+--
272replaceVarWithUnknown :: String -> Type -> Subst Type
334replaceVarWithUnknown :: String -> Type -> Subst Type
273replaceVarWithUnknown ident ty = do
335replaceVarWithUnknown ident ty = do
274 tu <- fresh
336 tu <- fresh
275 return $ replaceTypeVars ident tu $ ty
337 return $ replaceTypeVars ident tu $ ty
276
338
339+-- |
340+-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
341+-- better error messages during unification.
342+--
277replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d
343replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d
278replaceAllTypeSynonyms d = do
344replaceAllTypeSynonyms d = do
279 env <- getEnv
345 env <- getEnv
@@ -281,12 +347,18 @@ replaceAllTypeSynonyms d = do
281 let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
347 let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
282 either throwError return $ saturateAllTypeSynonyms env moduleName syns d
348 either throwError return $ saturateAllTypeSynonyms env moduleName syns d
283
349
350+-- |
351+-- \"Desaturate\" @SaturatedTypeSynonym@s
352+--
284desaturateAllTypeSynonyms :: (D.Data d) => d -> d
353desaturateAllTypeSynonyms :: (D.Data d) => d -> d
285desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
354desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
286 where
355 where
287 replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
356 replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
288 replaceSaturatedTypeSynonym t = t
357 replaceSaturatedTypeSynonym t = t
289
358
359+-- |
360+-- Replace a type synonym and its arguments with the aliased type
361+--
290expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
362expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
291expandTypeSynonym name args = do
363expandTypeSynonym name args = do
292 env <- getEnv
364 env <- getEnv
@@ -295,12 +367,21 @@ expandTypeSynonym name args = do
295 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
367 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
296 Nothing -> error "Type synonym was not defined"
368 Nothing -> error "Type synonym was not defined"
297
369
370+-- |
371+-- Ensure a set of property names and value does not contain duplicate labels
372+--
298ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
373ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
299ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
374ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
300
375
376+-- |
377+-- Infer a type for a value, rethrowing any error to provide a more useful error message
378+--
301infer :: Value -> Subst Value
379infer :: Value -> Subst Value
302infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val
380infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val
303
381
382+-- |
383+-- Infer a type for a value
384+--
304infer' :: Value -> Subst Value
385infer' :: Value -> Subst Value
305infer' v@(NumericLiteral _) = return $ TypedValue True v Number
386infer' v@(NumericLiteral _) = return $ TypedValue True v Number
306infer' v@(StringLiteral _) = return $ TypedValue True v String
387infer' v@(StringLiteral _) = return $ TypedValue True v String
@@ -399,6 +480,9 @@ infer' (TypedValue checkType val ty) = do
399 return $ TypedValue True val' ty
480 return $ TypedValue True val' ty
400infer' _ = error "Invalid argument to infer"
481infer' _ = error "Invalid argument to infer"
401
482
483+-- |
484+-- Infer the type of a property inside a record with a given type
485+--
402inferProperty :: Type -> String -> Subst (Maybe Type)
486inferProperty :: Type -> String -> Subst (Maybe Type)
403inferProperty (Object row) prop = do
487inferProperty (Object row) prop = do
404 let (props, _) = rowToList row
488 let (props, _) = rowToList row
@@ -411,6 +495,9 @@ inferProperty (ForAll ident ty) prop = do
411 inferProperty replaced prop
495 inferProperty replaced prop
412inferProperty _ _ = return Nothing
496inferProperty _ _ = return Nothing
413
497
498+-- |
499+-- Infer the type of a unary operator application
500+--
414inferUnary :: UnaryOperator -> Value -> Subst Value
501inferUnary :: UnaryOperator -> Value -> Subst Value
415inferUnary op (TypedValue _ val valTy) =
502inferUnary op (TypedValue _ val valTy) =
416 case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
503 case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
@@ -419,6 +506,9 @@ inferUnary op (TypedValue _ val valTy) =
419 return $ TypedValue True (Unary op val) resTy
506 return $ TypedValue True (Unary op val) resTy
420inferUnary _ _ = error "Invalid arguments to inferUnary"
507inferUnary _ _ = error "Invalid arguments to inferUnary"
421
508
509+-- |
510+-- Check the type of a unary operator application
511+--
422checkUnary :: UnaryOperator -> Value -> Type -> Subst Value
512checkUnary :: UnaryOperator -> Value -> Type -> Subst Value
423checkUnary op val res =
513checkUnary op val res =
424 case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
514 case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
@@ -427,12 +517,18 @@ checkUnary op val res =
427 val' <- check val valTy
517 val' <- check val valTy
428 return $ Unary op val'
518 return $ Unary op val'
429
519
520+-- |
521+-- Built-in unary operators
522+--
430unaryOps :: [(UnaryOperator, (Type, Type))]
523unaryOps :: [(UnaryOperator, (Type, Type))]
431unaryOps = [ (Negate, (Number, Number))
524unaryOps = [ (Negate, (Number, Number))
432 , (Not, (Boolean, Boolean))
525 , (Not, (Boolean, Boolean))
433 , (BitwiseNot, (Number, Number))
526 , (BitwiseNot, (Number, Number))
434 ]
527 ]
435
528
529+-- |
530+-- Infer the type of a binary operator application
531+--
436inferBinary :: BinaryOperator -> Value -> Value -> Subst Value
532inferBinary :: BinaryOperator -> Value -> Value -> Subst Value
437inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do
533inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do
438 leftTy ~~ rightTy
534 leftTy ~~ rightTy
@@ -445,6 +541,9 @@ inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) =
445 return $ TypedValue True (Binary op left right) resTy
541 return $ TypedValue True (Binary op left right) resTy
446inferBinary _ _ _ = error "Invalid arguments to inferBinary"
542inferBinary _ _ _ = error "Invalid arguments to inferBinary"
447
543
544+-- |
545+-- Check the type of a binary operator application
546+--
448checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst Value
547checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst Value
449checkBinary op left right res | isEqualityTest op = do
548checkBinary op left right res | isEqualityTest op = do
450 res ~~ Boolean
549 res ~~ Boolean
@@ -460,11 +559,17 @@ checkBinary op left right res =
460 right' <- check right valTy
559 right' <- check right valTy
461 return $ Binary op left' right'
560 return $ Binary op left' right'
462
561
562+-- |
563+-- Check if a @BinaryOperator@ is an equality test
564+--
463isEqualityTest :: BinaryOperator -> Bool
565isEqualityTest :: BinaryOperator -> Bool
464isEqualityTest EqualTo = True
566isEqualityTest EqualTo = True
465isEqualityTest NotEqualTo = True
567isEqualityTest NotEqualTo = True
466isEqualityTest _ = False
568isEqualityTest _ = False
467
569
570+-- |
571+-- Built-in binary operators
572+--
468binaryOps :: [(BinaryOperator, (Type, Type))]
573binaryOps :: [(BinaryOperator, (Type, Type))]
469binaryOps = [ (Add, (Number, Number))
574binaryOps = [ (Add, (Number, Number))
470 , (Subtract, (Number, Number))
575 , (Subtract, (Number, Number))
@@ -486,6 +591,9 @@ binaryOps = [ (Add, (Number, Number))
486 , (GreaterThanOrEqualTo, (Number, Boolean))
591 , (GreaterThanOrEqualTo, (Number, Boolean))
487 ]
592 ]
488
593
594+-- |
595+-- Infer the types of variables brought into scope by a binder
596+--
489inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
597inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
490inferBinder _ NullBinder = return M.empty
598inferBinder _ NullBinder = return M.empty
491inferBinder val (StringBinder _) = val ~~ String >> return M.empty
599inferBinder val (StringBinder _) = val ~~ String >> return M.empty
@@ -541,6 +649,9 @@ inferBinder val (NamedBinder name binder) = do
541 m <- inferBinder val binder
649 m <- inferBinder val binder
542 return $ M.insert name val m
650 return $ M.insert name val m
543
651
652+-- |
653+-- Check the types of the return values in a set of binders in a case statement
654+--
544checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst [([Binder], Maybe Guard, Value)]
655checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst [([Binder], Maybe Guard, Value)]
545checkBinders _ _ [] = return []
656checkBinders _ _ [] = return []
546checkBinders nvals ret ((binders, grd, val):bs) = do
657checkBinders nvals ret ((binders, grd, val):bs) = do
@@ -556,6 +667,9 @@ checkBinders nvals ret ((binders, grd, val):bs) = do
556 rs <- checkBinders nvals ret bs
667 rs <- checkBinders nvals ret bs
557 return $ r : rs
668 return $ r : rs
558
669
670+-- |
671+-- Check that a local variable name is not already used
672+--
559assignVariable :: Ident -> Subst ()
673assignVariable :: Ident -> Subst ()
560assignVariable name = do
674assignVariable name = do
561 env <- checkEnv <$> get
675 env <- checkEnv <$> get
@@ -564,6 +678,10 @@ assignVariable name = do
564 Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
678 Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
565 _ -> return ()
679 _ -> return ()
566
680
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+--
567checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type, Statement)
685checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type, Statement)
568checkStatement mass _ (VariableIntroduction name val) = do
686checkStatement mass _ (VariableIntroduction name val) = do
569 assignVariable name
687 assignVariable name
@@ -593,6 +711,9 @@ checkStatement mass ret (Return val) = do
593 val' <- check val ret
711 val' <- check val ret
594 return (True, mass, Return val')
712 return (True, mass, Return val')
595
713
714+-- |
715+-- Check the type of an if-then-else statement
716+--
596checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst (Bool, IfStatement)
717checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst (Bool, IfStatement)
597checkIfStatement mass ret (IfStatement val thens Nothing) = do
718checkIfStatement mass ret (IfStatement val thens Nothing) = do
598 val' <- check val Boolean
719 val' <- check val Boolean
@@ -604,12 +725,18 @@ checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
604 (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses
725 (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses
605 return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))
726 return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses'))
606
727
728+-- |
729+-- Check the type of an else statement
730+--
607checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst (Bool, ElseStatement)
731checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst (Bool, ElseStatement)
608checkElseStatement mass ret (Else elses) = do
732checkElseStatement mass ret (Else elses) = do
609 (allCodePathsReturn, _, elses') <- checkBlock mass ret elses
733 (allCodePathsReturn, _, elses') <- checkBlock mass ret elses
610 return (allCodePathsReturn, Else elses')
734 return (allCodePathsReturn, Else elses')
611checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement mass ret ifst
735checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement mass ret ifst
612
736
737+-- |
738+-- Check the type of the return value of a block of statements
739+--
613checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type, [Statement])
740checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type, [Statement])
614checkBlock mass _ [] = return (False, mass, [])
741checkBlock mass _ [] = return (False, mass, [])
615checkBlock mass ret (s:ss) = do
742checkBlock mass ret (s:ss) = do
@@ -622,11 +749,17 @@ checkBlock mass ret (s:ss) = do
622 (b, m, ss'') <- checkBlock mass1 ret ss'
749 (b, m, ss'') <- checkBlock mass1 ret ss'
623 return (b, m, s':ss'')
750 return (b, m, s':ss'')
624
751
752+-- |
753+-- Skolemize a type variable by replacing its instances with fresh skolem constants
754+--
625skolemize :: String -> Type -> Subst Type
755skolemize :: String -> Type -> Subst Type
626skolemize ident ty = do
756skolemize ident ty = do
627 tsk <- Skolem <$> fresh'
757 tsk <- Skolem <$> fresh'
628 return $ replaceTypeVars ident tsk ty
758 return $ replaceTypeVars ident tsk ty
629
759
760+-- |
761+-- Check the type of a value, rethrowing errors to provide a better error message
762+--
630check :: Value -> Type -> Subst Value
763check :: Value -> Type -> Subst Value
631check val ty = rethrow errorMessage $ check' val ty
764check val ty = rethrow errorMessage $ check' val ty
632 where
765 where
@@ -638,6 +771,9 @@ check val ty = rethrow errorMessage $ check' val ty
638 ":\n" ++
771 ":\n" ++
639 msg
772 msg
640
773
774+-- |
775+-- Check the type of a value
776+--
641check' :: Value -> Type -> Subst Value
777check' :: Value -> Type -> Subst Value
642check' val (ForAll idents ty) = do
778check' val (ForAll idents ty) = do
643 sk <- skolemize idents ty
779 sk <- skolemize idents ty
@@ -736,6 +872,11 @@ check' val (SaturatedTypeSynonym name args) = do
736 check val ty
872 check val ty
737check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
873check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
738
874
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+--
739checkProperties :: [(String, Value)] -> Type -> Bool -> Subst [(String, Value)]
880checkProperties :: [(String, Value)] -> Type -> Bool -> Subst [(String, Value)]
740checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
881checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
741 go [] [] REmpty = return []
882 go [] [] REmpty = return []
@@ -765,6 +906,9 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
765 return $ (p, v') : ps''
906 return $ (p, v') : ps''
766 go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
907 go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
767
908
909+-- |
910+-- Check the type of a function application, rethrowing errors to provide a better error message
911+--
768checkFunctionApplication :: Value -> Type -> [Value] -> Type -> Subst Value
912checkFunctionApplication :: Value -> Type -> [Value] -> Type -> Subst Value
769checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret
913checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret
770 where
914 where
@@ -773,6 +917,9 @@ checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunction
773 ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
917 ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
774 ++ ":\n" ++ msg
918 ++ ":\n" ++ msg
775
919
920+-- |
921+-- Check the type of a function application
922+--
776checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> Subst Value
923checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> Subst Value
777checkFunctionApplication' fn (Function argTys retTy) args ret = do
924checkFunctionApplication' fn (Function argTys retTy) args ret = do
778 guardWith "Incorrect number of function arguments" (length args == length argTys)
925 guardWith "Incorrect number of function arguments" (length args == length argTys)
@@ -800,12 +947,27 @@ checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of
800 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
947 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
801 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
948 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
802
949
950+-- |
951+-- Check whether one type subsumes another, rethrowing errors to provide a better error message
952+--
803subsumes :: Type -> Type -> Subst ()
953subsumes :: Type -> Type -> Subst ()
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 ()
804−subsumes (ForAll ident ty1) ty2 = do
966+subsumes' (ForAll ident ty1) ty2 = do
805 replaced <- replaceVarWithUnknown ident ty1
967 replaced <- replaceVarWithUnknown ident ty1
806 replaced `subsumes` ty2
968 replaced `subsumes` ty2
807−subsumes (Function args1 ret1) (Function args2 ret2) = do
969+subsumes' (Function args1 ret1) (Function args2 ret2) = do
808 zipWithM_ subsumes args2 args1
970 zipWithM_ subsumes args2 args1
809 ret1 `subsumes` ret2
971 ret1 `subsumes` ret2
810−subsumes ty1 ty2 = ty1 ~~ ty2
972+subsumes' ty1 ty2 = ty1 ~~ ty2
811
973
src/Language/PureScript/Types.hs+73
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Data types for types
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -22,37 +23,100 @@ import Data.Generics (mkT, mkQ, everywhereBut)
22import Language.PureScript.Names
23import Language.PureScript.Names
23import Language.PureScript.Unknown (Unknown(..))
24import Language.PureScript.Unknown (Unknown(..))
24
25
26+-- |
27+-- The type of types
28+--
25data Type
29data Type
30+ -- |
31+ -- A unification variable of type Type
32+ --
26 = TUnknown (Unknown Type)
33 = TUnknown (Unknown Type)
34+ -- |
35+ -- Javascript numbers
36+ --
27 | Number
37 | Number
38+ -- |
39+ -- Javascript strings
40+ --
28 | String
41 | String
42+ -- |
43+ -- Javascript booleans
44+ --
29 | Boolean
45 | Boolean
46+ -- |
47+ -- Javascript array type constructor
48+ --
30 | Array
49 | Array
50+ -- |
51+ -- Records, parameterized by a row of types
52+ --
31 | Object Type
53 | Object Type
54+ -- |
55+ -- A function, with zero or more arguments
56+ --
32 | Function [Type] Type
57 | Function [Type] Type
58+ -- |
59+ -- A named type variable
60+ --
33 | TypeVar String
61 | TypeVar String
62+ -- |
63+ -- A type constructor
64+ --
34 | TypeConstructor (Qualified ProperName)
65 | TypeConstructor (Qualified ProperName)
66+ -- |
67+ -- A type application
68+ --
35 | TypeApp Type Type
69 | TypeApp Type Type
70+ -- |
71+ -- A type synonym which is \"saturated\", i.e. fully applied
72+ --
36 | SaturatedTypeSynonym (Qualified ProperName) [Type]
73 | SaturatedTypeSynonym (Qualified ProperName) [Type]
74+ -- |
75+ -- Forall quantifier
76+ --
37 | ForAll String Type
77 | ForAll String Type
78+ -- |
79+ -- A type with a set of type class constraints
80+ --
38 | ConstrainedType [(Qualified ProperName, Type)] Type
81 | ConstrainedType [(Qualified ProperName, Type)] Type
82+ -- |
83+ -- A skolem constant
84+ --
39 | Skolem Int
85 | Skolem Int
86+ -- |
87+ -- An empty row
88+ --
40 | REmpty
89 | REmpty
90+ -- |
91+ -- A non-empty row
92+ --
41 | RCons String Type Type deriving (Show, Eq, Data, Typeable)
93 | RCons String Type Type deriving (Show, Eq, Data, Typeable)
42
94
95+-- |
96+-- Convert a row to a list of pairs of labels and types
97+--
43rowToList :: Type -> ([(String, Type)], Type)
98rowToList :: Type -> ([(String, Type)], Type)
44rowToList (RCons name ty row) = let (tys, rest) = rowToList row
99rowToList (RCons name ty row) = let (tys, rest) = rowToList row
45 in ((name, ty):tys, rest)
100 in ((name, ty):tys, rest)
46rowToList r = ([], r)
101rowToList r = ([], r)
47
102
103+-- |
104+-- Convert a list of labels and types to a row
105+--
48rowFromList :: ([(String, Type)], Type) -> Type
106rowFromList :: ([(String, Type)], Type) -> Type
49rowFromList ([], r) = r
107rowFromList ([], r) = r
50rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
108rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r))
51
109
110+-- |
111+-- Check whether a type is a monotype
112+--
52isMonoType :: Type -> Bool
113isMonoType :: Type -> Bool
53isMonoType (ForAll _ _) = False
114isMonoType (ForAll _ _) = False
54isMonoType ty = isPolyType ty
115isMonoType ty = isPolyType ty
55
116
117+-- |
118+-- Check whather a type is a valid polytype
119+--
56isPolyType :: Type -> Bool
120isPolyType :: Type -> Bool
57isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)
121isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps)
58isPolyType (Function args ret) = all isPolyType args && isPolyType ret
122isPolyType (Function args ret) = all isPolyType args && isPolyType ret
@@ -61,12 +125,21 @@ isPolyType (SaturatedTypeSynonym _ args) = all isPolyType args
61isPolyType (ForAll _ ty) = isPolyType ty
125isPolyType (ForAll _ ty) = isPolyType ty
62isPolyType _ = True
126isPolyType _ = True
63
127
128+-- |
129+-- Universally quantify a type
130+--
64mkForAll :: [String] -> Type -> Type
131mkForAll :: [String] -> Type -> Type
65mkForAll = flip . foldl . flip $ ForAll
132mkForAll = flip . foldl . flip $ ForAll
66
133
134+-- |
135+-- The empty record type
136+--
67unit :: Type
137unit :: Type
68unit = Object REmpty
138unit = Object REmpty
69
139
140+-- |
141+-- Replace a type variable, taking into account variable shadowing
142+--
70replaceTypeVars :: (Data d) => String -> Type -> d -> d
143replaceTypeVars :: (Data d) => String -> Type -> d -> d
71replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
144replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
72 where
145 where
src/Language/PureScript/Unknown.hs+4
@@ -9,6 +9,7 @@
9-- Portability :
9-- Portability :
10--
10--
11-- |
11-- |
12+-- Data type for unification variables
12--
13--
13-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
14
15
@@ -18,6 +19,9 @@ module Language.PureScript.Unknown where
18
19
19import Data.Data
20import Data.Data
20
21
22+-- |
23+-- The type of typed unification variables
24+--
21newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)
25newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)
22
26
23
27