purescript 0.3.3 → 0.3.4
raw patch · 46 files changed
+1823/−141 lines, 46 files
Files
- libraries/prelude/prelude.purs +257/−52
- purescript.cabal +2/−2
- src/Data/Generics/Extras.hs +4/−0
- src/Language/PureScript.hs +18/−0
- src/Language/PureScript/CodeGen.hs +7/−0
- src/Language/PureScript/CodeGen/Externs.hs +4/−0
- src/Language/PureScript/CodeGen/JS.hs +7/−0
- src/Language/PureScript/CodeGen/JS/AST.hs +91/−2
- src/Language/PureScript/CodeGen/Monad.hs +12/−0
- src/Language/PureScript/CodeGen/Optimize.hs +39/−9
- src/Language/PureScript/Declarations.hs +85/−1
- src/Language/PureScript/Kinds.hs +18/−0
- src/Language/PureScript/ModuleDependencies.hs +12/−8
- src/Language/PureScript/Names.hs +25/−1
- src/Language/PureScript/Options.hs +21/−2
- src/Language/PureScript/Parser.hs +13/−0
- src/Language/PureScript/Parser/Common.hs +165/−20
- src/Language/PureScript/Parser/Declarations.hs +10/−0
- src/Language/PureScript/Parser/JS.hs +4/−0
- src/Language/PureScript/Parser/Kinds.hs +4/−1
- src/Language/PureScript/Parser/State.hs +10/−2
- src/Language/PureScript/Parser/Types.hs +8/−2
- src/Language/PureScript/Parser/Values.hs +17/−2
- src/Language/PureScript/Pretty.hs +9/−0
- src/Language/PureScript/Pretty/Common.hs +63/−5
- src/Language/PureScript/Pretty/JS.hs +19/−0
- src/Language/PureScript/Pretty/Kinds.hs +4/−0
- src/Language/PureScript/Pretty/Types.hs +7/−0
- src/Language/PureScript/Pretty/Values.hs +7/−0
- src/Language/PureScript/Scope.hs +7/−0
- src/Language/PureScript/Sugar.hs +16/−0
- src/Language/PureScript/Sugar/BindingGroups.hs +14/−0
- src/Language/PureScript/Sugar/CaseDeclarations.hs +8/−1
- src/Language/PureScript/Sugar/DoNotation.hs +6/−0
- src/Language/PureScript/Sugar/Operators.hs +8/−0
- src/Language/PureScript/Sugar/TypeClasses.hs +13/−0
- src/Language/PureScript/Sugar/TypeDeclarations.hs +8/−0
- src/Language/PureScript/TypeChecker.hs +14/−0
- src/Language/PureScript/TypeChecker/Kinds.hs +19/−0
- src/Language/PureScript/TypeChecker/Monad.hs +178/−6
- src/Language/PureScript/TypeChecker/Synonyms.hs +10/−0
- src/Language/PureScript/TypeChecker/Types.hs +185/−4
- src/Language/PureScript/Types.hs +73/−0
- src/Language/PureScript/Unknown.hs +4/−0
- src/Language/PureScript/Values.hs +277/−7
- tests/Main.hs +41/−14
libraries/prelude/prelude.purs view
@@ -49,8 +49,9 @@ fromMaybe :: forall a. a -> Maybe a -> a fromMaybe a = maybe a Prelude.id - bindMaybe :: forall a b. Maybe a -> (a -> Maybe b) -> Maybe b- bindMaybe m f = maybe Nothing f m+ instance Prelude.Monad Maybe where+ ret = Just+ (>>=) m f = maybe Nothing f m module Either where @@ -60,11 +61,13 @@ either f _ (Left a) = f a either _ g (Right b) = g b - bindEither :: forall e a b. Either e a -> (a -> Either e b) -> Either e b- bindEither = either (\e _ -> Left e) (\a f -> f a) + instance Prelude.Monad (Either e) where+ ret = Right+ (>>=) = either (\e _ -> Left e) (\a f -> f a) module Arrays where + import Prelude import Maybe head :: forall a. [a] -> a@@ -97,27 +100,77 @@ \ return xs.length; \ \}" :: forall a. [a] -> Number - foreign import indexOf :: forall a. [a] -> a -> Number+ foreign import indexOf "function indexOf(l) {\+ \ return function (e) {\+ \ return l.indexOf(e);\+ \ };\+ \}" :: forall a. [a] -> a -> Number - foreign import lastIndexOf :: forall a. [a] -> a -> Number+ foreign import lastIndexOf "function lastIndexOf(l) {\+ \ return function (e) {\+ \ return l.lastIndexOf(e);\+ \ };\+ \}" :: forall a. [a] -> a -> Number - foreign import concat :: forall a. [a] -> [a] -> [a]+ foreign import concat "function concat(l1) {\+ \ return function (l2) {\+ \ return l1.concat(l2);\+ \ };\+ \}" :: forall a. [a] -> [a] -> [a] - foreign import join :: [String] -> String+ foreign import join "function join(l) {\+ \ return l.join();\+ \}" :: [String] -> String - foreign import joinWith :: [String] -> String -> String+ foreign import joinWith "function joinWith(l) {\+ \ return function (s) {\+ \ return l.join(s);\+ \ };\+ \}" :: [String] -> String -> String - foreign import push :: forall a. [a] -> a -> [a]+ foreign import push "function push(l) {\+ \ return function (e) {\+ \ var l1 = l.slice();\+ \ l1.push(e); \+ \ return l1;\+ \ };\+ \}" :: forall a. [a] -> a -> [a] - foreign import reverse :: forall a. [a] -> [a]+ foreign import reverse "function reverse(l) {\+ \ var l1 = l.slice();\+ \ l1.reverse(); \+ \ return l1;\+ \}" :: forall a. [a] -> [a] - foreign import shift :: forall a. [a] -> [a]+ foreign import shift "function shift(l) {\+ \ var l1 = l.slice();\+ \ l1.shift();\+ \ return l1;\+ \}" :: forall a. [a] -> [a] - foreign import slice :: forall a. Number -> Number -> [a] -> [a]+ foreign import slice "function slice(s) {\+ \ return function(e) {\+ \ return function (l) {\+ \ return l.slice(s, e);\+ \ };\+ \ };\+ \}" :: forall a. Number -> Number -> [a] -> [a] - foreign import sort :: forall a. [a] -> [a]+ foreign import sort "function sort(l) {\+ \ var l1 = l.slice();\+ \ l.sort();\+ \ return l1;\+ \}" :: forall a. [a] -> [a] - foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a]+ foreign import splice "function splice(s) {\+ \ return function(e) {\+ \ return function(l1) { \+ \ return function(l2) {\+ \ return l2.splice(s, e, l1);\+ \ }; \+ \ }; \+ \ };\+ \}":: forall a. Number -> Number -> [a] -> [a] -> [a] infixr 6 : @@ -158,6 +211,10 @@ all _ [] = true all p (a:as) = p a && all p as + instance (Prelude.Show a) => Prelude.Show [a] where+ show [] = "[]"+ show (x:xs) = show x ++ " : " ++ show xs+ module Tuple where import Arrays@@ -187,57 +244,141 @@ \ return s.length;\ \}" :: String -> Number - foreign import charAt :: Number -> String -> String+ foreign import charAt "function charAt(i) {\+ \ return function(s) {\+ \ return s.charAt(i); \+ \ };\+ \}" :: Number -> String -> String - foreign import indexOfS :: String -> String -> Number+ foreign import indexOfS "function indexOfS(s1) {\+ \ return function(s2) {\+ \ return s2.indexOf(s2);\+ \ }; \+ \}" :: String -> String -> Number - foreign import lastIndexOfS :: String -> String -> Number+ foreign import lastIndexOfS "function lastIndexOfS(s1) {\+ \ return function(s2) {\+ \ return s2.lastIndexOf(s2);\+ \ };\+ \}" :: String -> String -> Number - foreign import localeCompare :: String -> String -> Number+ foreign import localeCompare "function localeCompare(s1) {\+ \ return function(s2) { \+ \ return s1.localeCompare(s2);\+ \ };\+ \}" :: String -> String -> Number - foreign import replace :: String -> String -> String -> String+ foreign import replace "function replace(s1) {\+ \ return function(s2) {\+ \ return function(s3) {\+ \ return s3.replace(s1, s2);\+ \ };\+ \ };\+ \}" :: String -> String -> String -> String - foreign import sliceS :: Number -> Number -> String -> String+ foreign import sliceS "function sliceS(st) {\+ \ return function(e) {\+ \ return function(s) {\+ \ return s.slice(st, e);\+ \ };\+ \ };\+ \}" :: Number -> Number -> String -> String - foreign import split :: String -> String -> [String]+ foreign import split "function split(sep) {\+ \ return function(s) {\+ \ return s.split(s);\+ \ };\+ \}" :: String -> String -> [String] - foreign import substr :: Number -> Number -> String -> String+ foreign import substr "function substr(n1) {\+ \ return function(n2) {\+ \ return function(s) {\+ \ return s.substr(n1, n2);\+ \ };\+ \ };\+ \}" :: Number -> Number -> String -> String - foreign import substring :: Number -> Number -> String -> String+ foreign import substring "function substring(n1) {\+ \ return function(n2) {\+ \ return function(s) {\+ \ return s.substring(n1, n2);\+ \ };\+ \ };\+ \}" :: Number -> Number -> String -> String - foreign import toLower :: String -> String+ foreign import toLower "function toLower(s) {\+ \ return s.toLower();\+ \}" :: String -> String - foreign import toUpper :: String -> String+ foreign import toUpper "function toUpper(s) {\+ \ return s.toUpper();\+ \}" :: String -> String - foreign import trim :: String -> String+ foreign import trim "function trim(s) {\+ \ return s.trim();\+ \}" :: String -> String module Regex where foreign import data Regex :: * - foreign import regex :: String -> String -> Regex+ foreign import regex "function regex(s1) {\+ \ return function(s2) {\+ \ return new Regex(s1, s2);\+ \ };\+ \}" :: String -> String -> Regex - foreign import test :: Regex -> String -> Boolean+ foreign import test "function test(r) {\+ \ return function (s) { \+ \ return r.test(s);\+ \ };\+ \}" :: Regex -> String -> Boolean - foreign import match :: Regex -> String -> [String]+ foreign import match "function match(r) {\+ \ return function (s) {\+ \ return s.match(r); \+ \ };\+ \}" :: Regex -> String -> [String] - foreign import replaceR :: Regex -> String -> String -> String+ foreign import replaceR "function replaceR(r) {\+ \ return function(s1) {\+ \ return function(s2) { \+ \ return s2.replace(r, s1);\+ \ };\+ \ };\+ \}" :: Regex -> String -> String -> String - foreign import search :: Regex -> String -> Number+ foreign import search "function search(r) {\+ \ return function (s) {\+ \ return s.search(r);\+ \ };\+ \}" :: Regex -> String -> Number module Global where - foreign import nan :: Number+ foreign import nan "var nan = NaN;" :: Number - foreign import infinity :: Number+ foreign import infinity "var infinity = Infinity;" :: Number - foreign import toExponential :: Number -> String+ foreign import toExponential "function toExponential(n) {\+ \ return n.toExponential();\+ \}" :: Number -> String - foreign import toFixed :: Number -> Number -> String+ foreign import toFixed "function toFixed(d) {\+ \ return function(n) {\+ \ return n.toFixed(d);\+ \ };\+ \}" :: Number -> Number -> String - foreign import toPrecision :: Number -> Number -> String+ foreign import toPrecision "function toPrecision(d) {\+ \ return function(n) {\+ \ return n.toPrecision(d);\+ \ };\+ \}" :: Number -> Number -> String - foreign import numberToString :: Number -> String+ foreign import numberToString "function numberToString(n) {\+ \ return n.toString();\+ \}" :: Number -> String foreign import isNaN :: Number -> Boolean @@ -255,6 +396,9 @@ foreign import decodeURI :: String -> String + instance Prelude.Show Number where+ show = numberToString+ module Math where type Math = @@ -277,19 +421,31 @@ , tan :: Number -> Number } - foreign import math :: Math+ foreign import math "var math = Math;" :: Math module Eff where foreign import data Eff :: # ! -> * -> * - foreign import retEff "function retEff(a) { return function() { return a; }; }" :: forall e a. a -> Eff e a+ foreign import retEff "function retEff(a) { \+ \ return function() { \+ \ return a; \+ \ }; \+ \}" :: forall e a. a -> Eff e a - foreign import bindEff "function bindEff(a) { return function(f) { return function() { return f(a())(); }; }; }" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b + foreign import bindEff "function bindEff(a) { \+ \ return function(f) { \+ \ return function() { \+ \ return f(a())(); \+ \ }; \+ \ }; \+ \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b type Pure a = forall e. Eff e a - foreign import runPure "function runPure(f) { return f(); }" :: forall a. Pure a -> a+ foreign import runPure "function runPure(f) { \+ \ return f(); \+ \}" :: forall a. Pure a -> a instance Prelude.Monad (Eff e) where ret = retEff@@ -301,9 +457,23 @@ foreign import data Error :: * -> ! - foreign import throwError "function throwError(e) { return function() { throw e; }; }" :: forall a e r. e -> Eff (err :: Error e | r) a+ foreign import throwError "function throwError(e) { \+ \ return function() { \+ \ throw e; \+ \ }; \+ \}" :: forall a e r. e -> Eff (err :: Error e | r) a - foreign import catchError "function catchError(c) { return function(t) { return function() { try { return t(); } catch(e) { return c(e)(); } }; }; }" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a+ foreign import catchError "function catchError(c) { \+ \ return function(t) { \+ \ return function() { \+ \ try { \+ \ return t(); \+ \ } catch(e) { \+ \ return c(e)(); \+ \ }\+ \ }; \+ \ }; \+ \}" :: forall e r a. (e -> Eff r a) -> Eff (err :: Error e | r) a -> Eff r a module IORef where @@ -313,11 +483,25 @@ foreign import data IORef :: * -> * - foreign import newIORef :: forall s r. s -> Eff (ref :: Ref | r) (IORef s)+ foreign import newIORef "function newIORef(val) {\+ \ return function () {\+ \ return { value: val };\+ \ };\+ \}" :: forall s r. s -> Eff (ref :: Ref | r) (IORef s) - foreign import readIORef :: forall s r. IORef s -> Eff (ref :: Ref | r) s+ foreign import readIORef "function readIORef(ref) {\+ \ return function() {\+ \ return ref.value;\+ \ };\+ \}" :: forall s r. IORef s -> Eff (ref :: Ref | r) s - foreign import writeIORef :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {}+ foreign import writeIORef "function writeIORef(ref) {\+ \ return function(val) {\+ \ return function() {\+ \ ref.value = val;\+ \ };\+ \ };\+ \}" :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {} module Trace where @@ -326,7 +510,12 @@ foreign import data Trace :: ! - foreign import trace "function trace(s) { return function() { console.log(s); return {}; }; }" :: forall r. String -> Eff (trace :: Trace | r) {}+ foreign import trace "function trace(s) { \+ \ return function() { \+ \ console.log(s); \+ \ return {}; \+ \ }; \+ \}" :: forall r. String -> Eff (trace :: Trace | r) {} print :: forall a r. (Prelude.Show a) => a -> Eff (trace :: Trace | r) {} print o = trace (show o) @@ -339,11 +528,27 @@ foreign import data STRef :: * -> * -> * - foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)+ foreign import newSTRef "function newSTRef(val) {\+ \ return function () {\+ \ return { value: val };\+ \ };\+ \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a) - foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a+ foreign import readSTRef "function readSTRef(ref) {\+ \ return function() {\+ \ return ref.value;\+ \ };\+ \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a - foreign import modifySTRef :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {}+ foreign import modifySTRef "function modifySTRef(f) {\+ \ return function(ref) {\+ \ return function() {\+ \ ref.value = f(ref.value);\+ \ };\+ \ };\+ \}" :: forall a h r. (a -> a) -> STRef h a -> Eff (st :: ST h | r) {} - foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a+ foreign import runST "function runST(f) {\+ \ return f;\+ \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
purescript.cabal view
@@ -1,5 +1,5 @@ name: purescript-version: 0.3.3+version: 0.3.4 cabal-version: >=1.8 build-type: Simple license: MIT@@ -89,7 +89,7 @@ test-suite tests build-depends: base >=4 && <5, containers -any, directory -any, filepath -any, mtl -any, parsec -any, purescript -any, syb -any,- transformers -any, utf8-string -any+ transformers -any, utf8-string -any, process -any type: exitcode-stdio-1.0 main-is: Main.hs buildable: True
src/Data/Generics/Extras.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Additional SYB combinators -- ----------------------------------------------------------------------------- @@ -18,6 +19,9 @@ import Data.Data +-- |+-- Apply a top-down monadic transformation everywhere+-- everywhereM' :: (Monad m, Data d) => (forall d1. (Data d1) => d1 -> m d1) -> d -> m d everywhereM' f x = do y <- f x
src/Language/PureScript.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- The main compiler module -- ----------------------------------------------------------------------------- @@ -32,6 +33,23 @@ import Control.Applicative ((<$>)) import qualified Data.Map as M +-- |+-- Compile a collection of modules+--+-- The compilation pipeline proceeds as follows:+--+-- * Sort the modules based on module dependencies, checking for cyclic dependencies.+--+-- * Perform a set of desugaring passes.+--+-- * Type check, and elaborate values to include type annotations and type class dictionaries.+--+-- * Regroup values to take into account new value dependencies introduced by elaboration+--+-- * Generate Javascript, and perform optimization passes.+--+-- * Pretty-print the generated Javascript+-- compile :: Options -> [Module] -> Either String (String, String, Environment) compile opts ms = do sorted <- sortModules ms
src/Language/PureScript/CodeGen.hs view
@@ -9,6 +9,13 @@ -- Portability : -- -- |+-- A collection of modules related to code generation:+--+-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript+--+-- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files+--+-- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript -- -----------------------------------------------------------------------------
src/Language/PureScript/CodeGen/Externs.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations. -- ----------------------------------------------------------------------------- @@ -24,6 +25,9 @@ import Language.PureScript.Names import Data.List (intercalate) +-- |+-- Generate foreign imports for all declarations in a module+-- moduleToPs :: Module -> Environment -> String moduleToPs (Module pname@(ProperName moduleName) decls) env = "module " ++ moduleName ++ " where\n" ++
src/Language/PureScript/CodeGen/JS.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- This module generates code in the simplified Javascript intermediate representation from Purescript code -- ----------------------------------------------------------------------------- @@ -41,6 +42,9 @@ import Language.PureScript.Types import Language.PureScript.CodeGen.Optimize +-- |+-- Generate code in the simplified Javascript intermediate representation for all declarations in a module+-- moduleToJs :: Options -> Module -> Environment -> [JS] moduleToJs opts (Module pname@(ProperName name) decls) env = mapMaybe filterRawDecls decls ++@@ -58,6 +62,9 @@ typeClassesLast _ (ExternDeclaration TypeClassDictionaryImport _ _ _) = LT typeClassesLast _ _ = EQ +-- |+-- Generate code in the simplified Javascript intermediate representation for a declaration+-- declToJs :: Options -> ModuleName -> Declaration -> Environment -> Maybe [JS] declToJs opts mp (ValueDeclaration ident _ _ val) e = Just [ JSVariableIntroduction ident (Just (valueToJs opts mp e val)),
src/Language/PureScript/CodeGen/JS/AST.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Data types for the intermediate simplified-Javascript AST -- ----------------------------------------------------------------------------- @@ -21,36 +22,124 @@ import Data.Data +-- |+-- Data type for simplified Javascript expressions+-- data JS+ -- |+ -- A numeric literal+ -- = JSNumericLiteral (Either Integer Double)+ -- |+ -- A string literal+ -- | JSStringLiteral String+ -- |+ -- A boolean literal+ -- | JSBooleanLiteral Bool+ -- |+ -- A unary operator application+ -- | JSUnary UnaryOperator JS+ -- |+ -- A binary operator application+ -- | JSBinary BinaryOperator JS JS+ -- |+ -- An array literal+ -- | JSArrayLiteral [JS]+ -- |+ -- An array indexer expression+ -- | JSIndexer JS JS+ -- |+ -- An object literal+ -- | JSObjectLiteral [(String, JS)]+ -- |+ -- An object property accessor expression+ -- | JSAccessor String JS+ -- |+ -- A function introduction (optional name, arguments, body)+ -- | JSFunction (Maybe Ident) [Ident] JS+ -- |+ -- Function application+ -- | JSApp JS [JS]+ -- |+ -- Variable+ -- | JSVar Ident+ -- |+ -- Conditional expression+ -- | JSConditional JS JS JS+ -- |+ -- A block of expressions in braces+ -- | JSBlock [JS]+ -- |+ -- A variable introduction and optional initialization+ -- | JSVariableIntroduction Ident (Maybe JS)+ -- |+ -- A variable assignment+ -- | JSAssignment JSAssignment JS+ -- |+ -- While loop+ -- | JSWhile JS JS+ -- |+ -- For loop+ -- | JSFor Ident JS JS JS+ -- |+ -- If-then-else statement+ -- | JSIfElse JS JS (Maybe JS)+ -- |+ -- Return statement+ -- | JSReturn JS+ -- |+ -- Throw statement+ -- | JSThrow JS+ -- |+ -- Type-Of operator+ -- | JSTypeOf JS+ -- |+ -- Labelled statement+ -- | JSLabel String JS+ -- |+ -- Break statement+ -- | JSBreak String+ -- |+ -- Continue statement+ -- | JSContinue String+ -- |+ -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)+ -- | JSRaw String deriving (Show, Data, Typeable) +-- |+-- Data type for expressions which can appear on the left hand side of an assignment+-- data JSAssignment+ -- |+ -- Assign a variable+ -- = JSAssignVariable Ident+ -- |+ -- Assign an object property+ -- | JSAssignProperty String JSAssignment deriving (Show, Data, Typeable)--
src/Language/PureScript/CodeGen/Monad.hs view
@@ -9,7 +9,10 @@ -- Portability : -- -- |+-- Code generation monad --+-- This monad provides a supply of fresh names which can be used to create variables.+-- ----------------------------------------------------------------------------- {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -20,11 +23,20 @@ import Control.Applicative import Language.PureScript.Names +-- |+-- Code generation monad data type+-- newtype Gen a = Gen { unGen :: State [Ident] a } deriving (Functor, Applicative, Monad, MonadState [Ident]) +-- |+-- Run a computation in the code generation monad+-- runGen :: [Ident] -> Gen a -> a runGen names = flip evalState names . unGen +-- |+-- Generate a fresh name+-- fresh :: Gen Ident fresh = do (s:ss) <- get
src/Language/PureScript/CodeGen/Optimize.hs view
@@ -9,7 +9,24 @@ -- Portability : -- -- |+-- This module optimizes code in the simplified-Javascript intermediate representation. --+-- The following optimizations are supported:+--+-- * Collapsing nested blocks+--+-- * Tail call elimination+--+-- * Inlining of (>>=) and ret for the Eff monad+--+-- * Removal of unused variables+--+-- * Removal of unnecessary thunks+--+-- * Eta conversion+--+-- * Inlining variables+-- ----------------------------------------------------------------------------- module Language.PureScript.CodeGen.Optimize (@@ -28,6 +45,9 @@ (mkDictionaryValueName) import Language.PureScript.Types (Type(..)) +-- |+-- Apply a series of optimizer passes to simplified Javascript code+-- optimize :: Options -> JS -> JS optimize opts = collapseNestedBlocks@@ -58,12 +78,12 @@ check _ = False isRebound :: (Data d) => JS -> d -> Bool-isRebound (JSVar var1) = everything (||) (mkQ False check)+isRebound js d = any (\var -> isReassigned var d) (variablesOf js) where- check :: JS -> Bool- check (JSFunction _ args _) | var1 `elem` args = True- check _ = False-isRebound _ = const False+ variablesOf (JSVar var) = [var]+ variablesOf (JSAccessor _ val) = variablesOf val+ variablesOf (JSIndexer index val) = variablesOf index ++ variablesOf val+ variablesOf _ = [] isUsed :: (Data d) => Ident -> d -> Bool isUsed var1 = everything (||) (mkQ False check)@@ -72,10 +92,18 @@ check (JSVar var2) | var1 == var2 = True check (JSAssignment target _) | var1 == targetVariable target = True check _ = False- targetVariable :: JSAssignment -> Ident- targetVariable (JSAssignVariable var) = var- targetVariable (JSAssignProperty _ tgt) = targetVariable tgt +targetVariable :: JSAssignment -> Ident+targetVariable (JSAssignVariable var) = var+targetVariable (JSAssignProperty _ tgt) = targetVariable tgt++isUpdated :: (Data d) => Ident -> d -> Bool+isUpdated var1 = everything (||) (mkQ False check)+ where+ check :: JS -> Bool+ check (JSAssignment target _) | var1 == targetVariable target = True+ check _ = False+ shouldInline :: JS -> Bool shouldInline (JSVar _) = True shouldInline (JSNumericLiteral _) = True@@ -93,7 +121,9 @@ removeFromBlock js = js go :: [JS] -> [JS] go [] = []- go (JSVariableIntroduction var (Just js) : sts) | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) = go (replaceIdent var js sts)+ go (s@(JSVariableIntroduction var (Just js)) : sts)+ | shouldInline js && not (isReassigned var sts) && not (isRebound js sts) && not (isUpdated var sts) =+ go (replaceIdent var js sts) go (s:sts) = s : go sts removeUnusedVariables :: JS -> JS
src/Language/PureScript/Declarations.hs view
@@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : ----- |+-- | Data types for modules and declarations -- ----------------------------------------------------------------------------- @@ -24,59 +24,143 @@ import qualified Data.Data as D +-- |+-- A precedence level for an infix operator+-- type Precedence = Integer +-- |+-- Associativity for infix operators+-- data Associativity = Infixl | Infixr deriving (Show, D.Data, D.Typeable) +-- |+-- Fixity data for infix operators+-- data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable) +-- |+-- A module declaration, consisting of a module name and a list of declarations+-- data Module = Module ProperName [Declaration] deriving (Show, D.Data, D.Typeable) +-- |+-- The type of a foreign import+-- data ForeignImportType+ -- |+ -- A regular foreign import+ -- = ForeignImport+ -- |+ -- A type class dictionary import, generated during desugaring of type class declarations+ -- | TypeClassDictionaryImport+ -- |+ -- A type class dictionary member accessor import, generated during desugaring of type class declarations+ -- | TypeClassAccessorImport deriving (Show, Eq, D.Data, D.Typeable) +-- |+-- The data type of declarations+-- data Declaration+ -- |+ -- A data type declaration (name, arguments, data constructors)+ -- = DataDeclaration ProperName [String] [(ProperName, Maybe Type)]+ -- |+ -- A minimal mutually recursive set of data type declarations+ -- | DataBindingGroupDeclaration [Declaration]+ -- |+ -- A type synonym declaration (name, arguments, type)+ -- | TypeSynonymDeclaration ProperName [String] Type+ -- |+ -- A type declaration for a value (name, ty)+ -- | TypeDeclaration Ident Type+ -- |+ -- A value declaration (name, top-level binders, optional guard, value)+ -- | ValueDeclaration Ident [[Binder]] (Maybe Guard) Value+ -- |+ -- A minimal mutually recursive set of value declarations+ -- | BindingGroupDeclaration [(Ident, Value)]+ -- |+ -- A foreign import declaration (type, name, optional inline Javascript, type)+ -- | ExternDeclaration ForeignImportType Ident (Maybe JS) Type+ -- |+ -- A data type foreign import (name, kind)+ -- | ExternDataDeclaration ProperName Kind+ -- |+ -- A fixity declaration (fixity data, operator name)+ -- | FixityDeclaration Fixity String+ -- |+ -- A module import (module name, optional set of identifiers to import)+ -- | ImportDeclaration ModuleName (Maybe [Either Ident ProperName])+ -- |+ -- A type class declaration (name, argument, member declarations)+ -- | TypeClassDeclaration ProperName String [Declaration]+ -- |+ -- A type instance declaration (dependencies, class name, instance type, member declarations)+ -- | TypeInstanceDeclaration [(Qualified ProperName, Type)] (Qualified ProperName) Type [Declaration] deriving (Show, D.Data, D.Typeable) +-- |+-- Test if a declaration is a value declaration+-- isValueDecl :: Declaration -> Bool isValueDecl (ValueDeclaration _ _ _ _) = True isValueDecl _ = False +-- |+-- Test if a declaration is a data type or type synonym declaration+-- isDataDecl :: Declaration -> Bool isDataDecl (DataDeclaration _ _ _) = True isDataDecl (TypeSynonymDeclaration _ _ _) = True isDataDecl _ = False +-- |+-- Test if a declaration is a module import+-- isImportDecl :: Declaration -> Bool isImportDecl (ImportDeclaration _ _) = True isImportDecl _ = False +-- |+-- Test if a declaration is a data type foreign import+-- isExternDataDecl :: Declaration -> Bool isExternDataDecl (ExternDataDeclaration _ _) = True isExternDataDecl _ = False +-- |+-- Test if a declaration is a fixity declaration+-- isFixityDecl :: Declaration -> Bool isFixityDecl (FixityDeclaration _ _) = True isFixityDecl _ = False +-- |+-- Test if a declaration is a foreign import+-- isExternDecl :: Declaration -> Bool isExternDecl (ExternDeclaration _ _ _ _) = True isExternDecl _ = False +-- |+-- Test if a declaration is a type class or instance declaration+-- isTypeClassDeclaration :: Declaration -> Bool isTypeClassDeclaration (TypeClassDeclaration _ _ _) = True isTypeClassDeclaration (TypeInstanceDeclaration _ _ _ _) = True
src/Language/PureScript/Kinds.hs view
@@ -19,9 +19,27 @@ import Data.Data import Language.PureScript.Unknown +-- |+-- The data type of kinds+-- data Kind+ -- |+ -- Unification variable of type Kind+ -- = KUnknown (Unknown Kind)+ -- |+ -- The kind of types+ -- | Star+ -- |+ -- The kind of effects+ -- | Bang+ -- |+ -- Kinds for labelled, unordered rows without duplicates+ -- | Row Kind+ -- |+ -- Function kinds+ -- | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
src/Language/PureScript/ModuleDependencies.hs view
@@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : ----- |+-- | Provides the ability to sort modules based on module dependencies -- ----------------------------------------------------------------------------- @@ -27,18 +27,19 @@ import Language.PureScript.Values import Language.PureScript.Types +-- |+-- Sort a collection of modules based on module dependencies.+--+-- Reports an error if the module graph contains a cycle.+-- sortModules :: [Module] -> Either String [Module] sortModules ms = do let verts = map (\m -> (m, getModuleName m, usedModules m)) ms mapM toModule $ stronglyConnComp verts -collapseBindingGroups :: [Declaration] -> [Declaration]-collapseBindingGroups ds = concatMap go ds- where- go (DataBindingGroupDeclaration ds) = ds- go (BindingGroupDeclaration ds) = map (\(ident, val) -> ValueDeclaration ident [] Nothing val) ds- go other = [other]-+-- |+-- Calculate a list of used modules based on explicit imports and qualified names+-- usedModules :: (Data d) => d -> [ProperName] usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProperNames `extQ` imports) where@@ -55,6 +56,9 @@ getModuleName :: Module -> ProperName getModuleName (Module pn _) = pn +-- |+-- Convert a strongly connected component of the module graph to a module+-- toModule :: SCC Module -> Either String Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m
src/Language/PureScript/Names.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Data types for names -- ----------------------------------------------------------------------------- @@ -18,28 +19,51 @@ import Data.Data -data Ident = Ident String | Op String deriving (Eq, Ord, Data, Typeable)+-- |+-- Names for value identifiers+--+data Ident+ -- |+ -- An alphanumeric identifier+ --+ = Ident String+ -- |+ -- A symbolic name for an infix operator+ --+ | Op String deriving (Eq, Ord, Data, Typeable) instance Show Ident where show (Ident s) = s show (Op op) = '(':op ++ ")" +-- |+-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.+-- newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable) instance Show ProperName where show = runProperName +-- |+-- Module names+-- data ModuleName = ModuleName ProperName deriving (Eq, Ord, Data, Typeable) instance Show ModuleName where show (ModuleName name) = show name +-- |+-- A qualified name, i.e. a name with an optional module name+-- data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable) instance (Show a) => Show (Qualified a) where show (Qualified Nothing a) = show a show (Qualified (Just (ModuleName name)) a) = show name ++ "." ++ show a +-- |+-- Provide a default module name, if a name is unqualified+-- qualify :: ModuleName -> Qualified a -> (ModuleName, a) qualify m (Qualified Nothing a) = (m, a) qualify _ (Qualified (Just m) a) = (m, a)
src/Language/PureScript/Options.hs view
@@ -9,17 +9,36 @@ -- Portability : -- -- |+-- The data type of compiler options -- ----------------------------------------------------------------------------- module Language.PureScript.Options where -data Options = Options- { optionsTco :: Bool+-- |+-- The data type of compiler options+--+data Options = Options {+ -- |+ -- Perform tail-call elimination+ --+ optionsTco :: Bool+ -- |+ -- Perform type checks at runtime+ -- , optionsPerformRuntimeTypeChecks :: Bool+ -- |+ -- Inline calls to ret and bind for the Eff monad+ -- , optionsMagicDo :: Bool+ -- |+ -- Check the type of Main.main and generate its code+ -- , optionsRunMain :: Bool } deriving Show +-- |+-- Default compiler options+-- defaultOptions :: Options defaultOptions = Options False False False False
src/Language/PureScript/Parser.hs view
@@ -9,6 +9,19 @@ -- Portability : -- -- |+-- A collection of parsers for core data types:+--+-- [@Language.PureScript.Parser.Kinds@] Parser for kinds+--+-- [@Language.PureScript.Parser.Values@] Parser for values+--+-- [@Language.PureScript.Parser.Types@] Parser for types+--+-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules+--+-- [@Language.PureScript.Parser.State@] Parser state, including indentation+--+-- [@Language.PureScript.Parser.Common@] Common parsing utility functions -- -----------------------------------------------------------------------------
src/Language/PureScript/Parser/Common.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Constants, and utility functions to be used when parsing -- ----------------------------------------------------------------------------- @@ -25,6 +26,9 @@ import Language.PureScript.Names +-- |+-- A list of reserved identifiers+-- reservedNames :: [String] reservedNames = [ "case" , "of"@@ -76,28 +80,52 @@ , "instance" , "where" ] +-- |+-- A list of built-in operator names+-- builtInOperators :: [String] builtInOperators = [ "~", "-", "<=", ">=", "<", ">", "*", "/", "%", "++", "+", "<<", ">>>", ">>" , "==", "!=", "&&", "||", "&", "^", "|", "!!", "!" ] +-- |+-- A list of reserved operators+-- reservedOpNames :: [String] reservedOpNames = builtInOperators ++ [ "=>", "->", "=", ".", "\\" ] +-- |+-- Valid first characters for an identifier+-- identStart :: P.Parsec String u Char identStart = P.lower <|> P.oneOf "_" +-- |+-- Valid first characters for a proper name+-- properNameStart :: P.Parsec String u Char properNameStart = P.upper +-- |+-- Valid identifier characters+-- identLetter :: P.Parsec String u Char identLetter = P.alphaNum <|> P.oneOf "_'" +-- |+-- Valid first characters for an operator+-- opStart :: P.Parsec String u Char opStart = P.oneOf ":!#$%&*+./<=>?@\\^|-~" +-- |+-- Valid operators characters+-- opLetter :: P.Parsec String u Char opLetter = P.oneOf ":!#$%&*+./<=>?@\\^|-~" +-- |+-- The PureScript language definition+-- langDef :: PT.GenLanguageDef String u Identity langDef = PT.LanguageDef { PT.reservedNames = reservedNames@@ -113,104 +141,209 @@ , PT.caseSensitive = True } +-- |+-- A token parser based on the language definition+-- tokenParser :: PT.GenTokenParser String u Identity tokenParser = PT.makeTokenParser langDef +-- |+-- Parse a token+-- lexeme :: P.Parsec String u a -> P.Parsec String u a lexeme = PT.lexeme tokenParser +-- |+-- Parse an identifier+-- identifier :: P.Parsec String u String identifier = PT.identifier tokenParser +-- |+-- Parse a reserved word+-- reserved :: String -> P.Parsec String u () reserved = PT.reserved tokenParser +-- |+-- Parse a reserved operator+-- reservedOp :: String -> P.Parsec String u () reservedOp = PT.reservedOp tokenParser +-- |+-- Parse an operator+-- operator :: P.Parsec String u String operator = PT.operator tokenParser +-- |+-- Parse a string literal+-- stringLiteral :: P.Parsec String u String stringLiteral = PT.stringLiteral tokenParser +-- |+-- Parse whitespace+-- whiteSpace :: P.Parsec String u () whiteSpace = PT.whiteSpace tokenParser +-- |+-- Semicolon+-- semi :: P.Parsec String u String semi = PT.semi tokenParser +-- |+-- Colon+-- colon :: P.Parsec String u String colon = PT.colon tokenParser +-- |+-- Period+-- dot :: P.Parsec String u String dot = PT.dot tokenParser +-- |+-- Comma+-- comma :: P.Parsec String u String comma = PT.comma tokenParser +-- |+-- Backtick+-- tick :: P.Parsec String u Char tick = lexeme $ P.char '`' +-- |+-- Pipe character+-- pipe :: P.Parsec String u Char pipe = lexeme $ P.char '|' +-- |+-- Natural number+-- natural :: P.Parsec String u Integer natural = PT.natural tokenParser +-- |+-- Parse a proper name+--+properName :: P.Parsec String u ProperName+properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")++-- |+-- Parse a qualified name, i.e. M.name or just name+--+parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)+parseQualified parser = qual+ where+ qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)+ <|> (Qualified Nothing <$> P.try parser)+ delimiter = indented *> dot++-- |+-- Parse an integer or floating point value+--+integerOrFloat :: P.Parsec String u (Either Integer Double)+integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>+ Right <$> P.try (PT.float tokenParser)) P.<?> "number"++-- |+-- Parse an operator or a built-in operator+--+operatorOrBuiltIn :: P.Parsec String u String+operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)++-- |+-- Parse an identifier or parenthesized operator+--+parseIdent :: P.Parsec String ParseState Ident+parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)++-- |+-- Parse a token inside square brackets+-- squares :: P.Parsec String ParseState a -> P.Parsec String ParseState a squares = P.between (lexeme $ P.char '[') (lexeme $ indented *> P.char ']') . (indented *>) +-- |+-- Parse a token inside parentheses+-- parens :: P.Parsec String ParseState a -> P.Parsec String ParseState a parens = P.between (lexeme $ P.char '(') (lexeme $ indented *> P.char ')') . (indented *>) +-- |+-- Parse a token inside braces+-- braces :: P.Parsec String ParseState a -> P.Parsec String ParseState a braces = P.between (lexeme $ P.char '{') (lexeme $ indented *> P.char '}') . (indented *>) +-- |+-- Parse a token inside angle brackets+-- angles :: P.Parsec String ParseState a -> P.Parsec String ParseState a angles = P.between (lexeme $ P.char '<') (lexeme $ indented *> P.char '>') . (indented *>) +-- |+-- Parse zero or more values separated by a separator token+-- sepBy :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a] sepBy p s = P.sepBy (indented *> p) (indented *> s) +-- |+-- Parse one or more values separated by a separator token+-- sepBy1 :: P.Parsec String ParseState a -> P.Parsec String ParseState sep -> P.Parsec String ParseState [a] sepBy1 p s = P.sepBy1 (indented *> p) (indented *> s) +-- |+-- Parse zero or more values separated by semicolons+-- semiSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a] semiSep = flip sepBy semi +-- |+-- Parse one or more values separated by semicolons+-- semiSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a] semiSep1 = flip sepBy1 semi +-- |+-- Parse zero or more values separated by commas+-- commaSep :: P.Parsec String ParseState a -> P.Parsec String ParseState [a] commaSep = flip sepBy comma +-- |+-- Parse one or more values separated by commas+-- commaSep1 :: P.Parsec String ParseState a -> P.Parsec String ParseState [a] commaSep1 = flip sepBy1 comma -properName :: P.Parsec String u ProperName-properName = lexeme $ ProperName <$> P.try ((:) <$> P.upper <*> many (PT.identLetter langDef) P.<?> "name")--parseQualified :: P.Parsec String ParseState a -> P.Parsec String ParseState (Qualified a)-parseQualified parser = qual- where- qual = (Qualified <$> (Just . ModuleName <$> P.try (properName <* delimiter)) <*> parser)- <|> (Qualified Nothing <$> P.try parser)- delimiter = indented *> dot--integerOrFloat :: P.Parsec String u (Either Integer Double)-integerOrFloat = (Left <$> P.try (PT.natural tokenParser) <|>- Right <$> P.try (PT.float tokenParser)) P.<?> "number"-+-- |+-- Run the first parser, then match the second if possible, applying the specified function on a successful match+-- augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q +-- |+-- Run the first parser, then match the second zero or more times, applying the specified function for each match+-- fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a fold first more combine = do a <- first bs <- P.many more return $ foldl combine a bs +-- |+-- Build a parser from a smaller parser and a list of parsers for postfix operators+-- buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a buildPostfixParser fs first = do a <- first@@ -222,15 +355,15 @@ Nothing -> return a Just a' -> go a' -operatorOrBuiltIn :: P.Parsec String u String-operatorOrBuiltIn = P.try operator <|> P.choice (map (\s -> P.try (reservedOp s) >> return s) builtInOperators)--parseIdent :: P.Parsec String ParseState Ident-parseIdent = (Ident <$> identifier) <|> (Op <$> parens operatorOrBuiltIn)-+-- |+-- Parse an identifier in backticks or an operator+-- parseIdentInfix :: P.Parsec String ParseState (Qualified Ident) parseIdentInfix = (P.between tick tick (parseQualified (Ident <$> identifier))) <|> parseQualified (Op <$> operatorOrBuiltIn) +-- |+-- Mark the current indentation level+-- mark :: P.Parsec String ParseState a -> P.Parsec String ParseState a mark p = do current <- indentationLevel <$> P.getState@@ -240,17 +373,29 @@ P.modifyState $ \st -> st { indentationLevel = current } return a +-- |+-- Check that the current identation level matches a predicate+-- checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec String ParseState () checkIndentation rel = do col <- P.sourceColumn <$> P.getPosition current <- indentationLevel <$> P.getState guard (col `rel` current) +-- |+-- Check that the current indentation level is past the current mark+-- indented :: P.Parsec String ParseState () indented = checkIndentation (>) P.<?> "indentation" +-- |+-- Check that the current indentation level is at the same indentation as the current mark+-- same :: P.Parsec String ParseState () same = checkIndentation (==) P.<?> "no indentation" +-- |+-- Run a parser which supports indentation+-- runIndentParser :: P.Parsec String ParseState a -> String -> Either P.ParseError a runIndentParser p = P.runParser p (ParseState 0) ""
src/Language/PureScript/Parser/Declarations.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Parsers for module definitions and declarations -- ----------------------------------------------------------------------------- @@ -120,6 +121,9 @@ members <- mark (P.many (same *> parseValueDeclaration)) return $ TypeInstanceDeclaration (fromMaybe [] deps) className ty members +-- |+-- Parse a single declaration+-- parseDeclaration :: P.Parsec String ParseState Declaration parseDeclaration = P.choice [ parseDataDeclaration@@ -132,6 +136,9 @@ , parseTypeClassDeclaration , parseTypeInstanceDeclaration ] P.<?> "declaration" +-- |+-- Parse a module header and a collection of declarations+-- parseModule :: P.Parsec String ParseState Module parseModule = do reserved "module"@@ -141,5 +148,8 @@ decls <- mark (P.many (same *> parseDeclaration)) return $ Module name decls +-- |+-- Parse a collection of modules+-- parseModules :: P.Parsec String ParseState [Module] parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
src/Language/PureScript/Parser/JS.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- A parser for a small fragment of Javascript -- ----------------------------------------------------------------------------- @@ -99,6 +100,9 @@ unary :: UnaryOperator -> String -> P.Operator String u Identity JS unary op s = P.Prefix (P.try $ C.reservedOp s >> return (JSUnary op)) +-- |+-- Parse a simplified Javascript expression+-- parseJS :: P.Parsec String u JS parseJS = (P.buildExpressionParser operators
src/Language/PureScript/Parser/Kinds.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- A parser for kinds -- ----------------------------------------------------------------------------- @@ -34,7 +35,9 @@ [ parseStar , parseBang , parens parseKind ])-+-- |+-- Parse a kind+-- parseKind :: P.Parsec String ParseState Kind parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind" where
src/Language/PureScript/Parser/State.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- State for the parser monad -- ----------------------------------------------------------------------------- @@ -16,7 +17,14 @@ import qualified Text.Parsec as P -data ParseState = ParseState- { indentationLevel :: P.Column } deriving Show+-- |+-- State for the parser monad+--+data ParseState = ParseState {+ -- |+ -- The most recently marked indentation level+ --+ indentationLevel :: P.Column+ } deriving Show
src/Language/PureScript/Parser/Types.hs view
@@ -9,13 +9,13 @@ -- Portability : -- -- |+-- Parsers for types -- ----------------------------------------------------------------------------- module Language.PureScript.Parser.Types ( parseType,- parsePolyType,- parseRow+ parsePolyType ) where import Language.PureScript.Types@@ -97,12 +97,18 @@ postfixTable = [ \x -> TypeApp x <$> P.try (indented *> parseTypeAtom) ] operators = [ [ P.Infix (lexeme (P.try (P.string "->")) >> return (\t1 t2 -> Function [t1] t2)) P.AssocRight ] ] +-- |+-- Parse a monotype+-- parseType :: P.Parsec String ParseState Type parseType = do ty <- parseAnyType unless (isMonoType ty) $ P.unexpected "polymorphic type" return ty +-- |+-- Parse a polytype+-- parsePolyType :: P.Parsec String ParseState Type parsePolyType = do ty <- parseAnyType
src/Language/PureScript/Parser/Values.hs view
@@ -9,15 +9,16 @@ -- Portability : -- -- |+-- Parsers for values, statements, binders and guards -- ----------------------------------------------------------------------------- module Language.PureScript.Parser.Values ( parseValue,+ parseStatement, parseGuard, parseBinder, parseBinderNoParens,- parseDoNotationElement ) where import Language.PureScript.Values@@ -146,6 +147,9 @@ , parseDoNotationLet , P.try (DoNotationValue <$> parseValue) ] +-- |+-- Parse a value+-- parseValue :: P.Parsec String ParseState Value parseValue = (buildExpressionParser operators@@ -212,6 +216,9 @@ parseReturn :: P.Parsec String ParseState Statement parseReturn = Return <$> (C.reserved "return" *> parseValue <* C.indented <* C.semi) +-- |+-- Parse a statement+-- parseStatement :: P.Parsec String ParseState Statement parseStatement = P.choice [ parseVariableIntroduction@@ -273,11 +280,17 @@ , parseArrayBinder , C.parens parseBinder ]) P.<?> "binder" +-- |+-- Parse a binder+-- parseBinder :: P.Parsec String ParseState Binder parseBinder = (buildExpressionParser operators parseBinderAtom) P.<?> "expression" where operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ] +-- |+-- Parse a binder as it would appear in a top level declaration+-- parseBinderNoParens :: P.Parsec String ParseState Binder parseBinderNoParens = P.choice (map P.try [ parseNullBinder@@ -290,7 +303,9 @@ , parseObjectBinder , parseArrayBinder , C.parens parseBinder ]) P.<?> "binder"-+-- |+-- Parse a guard+-- parseGuard :: P.Parsec String ParseState Guard parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
src/Language/PureScript/Pretty.hs view
@@ -9,6 +9,15 @@ -- Portability : -- -- |+-- A collection of pretty printers for core data types:+--+-- [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds+--+-- [@Language.PureScript.Pretty.Values@] Pretty printer for values+--+-- [@Language.PureScript.Pretty.Types@] Pretty printer for types+--+-- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation -- -----------------------------------------------------------------------------
src/Language/PureScript/Pretty/Common.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Common pretty-printing utility functions -- ----------------------------------------------------------------------------- @@ -25,50 +26,107 @@ import Language.PureScript.Names +-- |+-- Convert an Ident into a valid Javascript identifier:+--+-- * Alphanumeric characters are kept unmodified+--+-- * Symbols are encoded as a dollar symbol ($) followed by their ordinal value+-- identToJs :: Ident -> String-identToJs (Ident name) = name-identToJs (Op op) = concatMap opCharToString op- where- opCharToString :: Char -> String- opCharToString = (:) '$'. show . ord+identToJs (Ident name) = concatMap identCharToString name+identToJs (Op op) = concatMap identCharToString op +identCharToString :: Char -> String+identCharToString c | isAlphaNum c = [c]+identCharToString '_' = "_"+identCharToString c = '$' : show (ord c)++-- |+-- A first-order pattern match+--+-- A pattern is a Kleisli arrow for the @StateT Maybe@ monad. That is, patterns can fail, and can carry user-defined state.+-- newtype Pattern u a b = Pattern { runPattern :: A.Kleisli (StateT u Maybe) a b } deriving (C.Category, A.Arrow, A.ArrowZero, A.ArrowPlus) instance Functor (Pattern u a) where fmap f (Pattern p) = Pattern $ A.Kleisli $ fmap f . A.runKleisli p +-- |+-- Run a pattern with an input and initial user state+--+-- Returns Nothing if the pattern fails to match+-- pattern :: Pattern u a b -> u -> a -> Maybe b pattern p u = flip evalStateT u . A.runKleisli (runPattern p) +-- |+-- Construct a pattern from a function+-- mkPattern :: (a -> Maybe b) -> Pattern u a b mkPattern f = Pattern $ A.Kleisli (lift . f) +-- |+-- Construct a pattern from a stateful function+-- mkPattern' :: (a -> StateT u Maybe b) -> Pattern u a b mkPattern' = Pattern . A.Kleisli +-- |+-- Wrap a string in parentheses+-- parens :: String -> String parens s = ('(':s) ++ ")" +-- |+-- Construct a pattern which recursively matches on the left-hand-side+-- chainl :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r chainl g f p = fix $ \c -> g >>> ((c <+> p) *** p) >>> A.arr (uncurry f) +-- |+-- Construct a pattern which recursively matches on the right-hand side+-- chainr :: Pattern u a (a, a) -> (r -> r -> r) -> Pattern u a r -> Pattern u a r chainr g f p = fix $ \c -> g >>> (p *** (c <+> p)) >>> A.arr (uncurry f) +-- |+-- Construct a pattern which recursively matches on one-side of a tuple+-- wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Pattern u a r -> Pattern u a r wrap g f p = fix $ \c -> g >>> (C.id *** (c <+> p)) >>> A.arr (uncurry f) +-- |+-- Construct a pattern which matches a part of a tuple+-- split :: Pattern u a (s, t) -> (s -> t -> r) -> Pattern u a r split s f = s >>> A.arr (uncurry f) +-- |+-- A table of operators+-- data OperatorTable u a r = OperatorTable { runOperatorTable :: [ [Operator u a r] ] } +-- |+-- An operator:+--+-- [@AssocL@] A left-associative operator+--+-- [@AssocR@] A right-associative operator+--+-- [@Wrap@] A prefix-like or postfix-like operator+--+-- [@Split@] A prefix-like or postfix-like operator which does not recurse into its operand+-- data Operator u a r where AssocL :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r AssocR :: Pattern u a (a, a) -> (r -> r -> r) -> Operator u a r Wrap :: Pattern u a (s, a) -> (s -> r -> r) -> Operator u a r Split :: Pattern u a (s, t) -> (s -> t -> r) -> Operator u a r +-- |+-- Build a pretty printer from an operator table and an indecomposable pattern+-- buildPrettyPrinter :: OperatorTable u a r -> Pattern u a r -> Pattern u a r buildPrettyPrinter table p = foldl (\p' ops -> foldl1 (<+>) (flip map ops $ \op -> case op of
src/Language/PureScript/Pretty/JS.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Pretty printer for the Javascript AST -- ----------------------------------------------------------------------------- @@ -30,9 +31,15 @@ newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord) +-- |+-- Number of characters per identation level+-- blockIndent :: Int blockIndent = 4 +-- |+-- Pretty print with a new indentation level+-- withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String withIndent action = do modify $ \st -> st { indent = indent st + blockIndent }@@ -40,6 +47,9 @@ modify $ \st -> st { indent = indent st - blockIndent } return result +-- |+-- Get the current indentation level+-- currentIndent :: StateT PrinterState Maybe String currentIndent = do current <- get@@ -187,15 +197,24 @@ match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2) match' _ = Nothing +-- |+-- Generate a pretty-printed string representing a Javascript expression+-- prettyPrintJS1 :: JS -> String prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS' +-- |+-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level+-- prettyPrintJS :: [JS] -> String prettyPrintJS sts = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) $ do jss <- forM sts prettyPrintJS' indentString <- currentIndent return $ intercalate "\n" $ map (++ ";") $ map (indentString ++) jss +-- |+-- Generate an indented, pretty-printed string representing a Javascript expression+-- prettyPrintJS' :: JS -> StateT PrinterState Maybe String prettyPrintJS' = A.runKleisli $ runPattern matchValue where
src/Language/PureScript/Pretty/Kinds.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Pretty printer for kinds -- ----------------------------------------------------------------------------- @@ -43,6 +44,9 @@ match (FunKind arg ret) = Just (arg, ret) match _ = Nothing +-- |+-- Generate a pretty-printed string representing a Kind+-- prettyPrintKind :: Kind -> String prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind () where
src/Language/PureScript/Pretty/Types.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Pretty printer for Types -- ----------------------------------------------------------------------------- @@ -44,6 +45,9 @@ match row@(RCons _ _ _) = Just $ prettyPrintRow row match _ = Nothing +-- |+-- Generate a pretty-printed string representing a Row+-- prettyPrintRow :: Type -> String prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList [] where@@ -77,6 +81,9 @@ match (Function args ret) = Just (args, ret) match _ = Nothing +-- |+-- Generate a pretty-printed string representing a Type+-- prettyPrintType :: Type -> String prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () where
src/Language/PureScript/Pretty/Values.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Pretty printer for values -- ----------------------------------------------------------------------------- @@ -113,6 +114,9 @@ prettyPrintDoNotationElement (DoNotationBind binder val) = prettyPrintBinder binder ++ " <- " ++ prettyPrintValue val prettyPrintDoNotationElement (DoNotationLet binder val) = "let " ++ prettyPrintBinder binder ++ " = " ++ prettyPrintValue val +-- |+-- Generate a pretty-printed string representing a Value+-- prettyPrintValue :: Value -> String prettyPrintValue = fromMaybe (error "Incomplete pattern") . pattern matchValue () where@@ -170,6 +174,9 @@ match (NamedBinder ident binder) = Just $ show ident ++ "@" ++ prettyPrintBinder binder match _ = Nothing +-- |+-- Generate a pretty-printed string representing a Binder+-- prettyPrintBinder :: Binder -> String prettyPrintBinder = fromMaybe (error "Incomplete pattern") . pattern matchBinder () where
src/Language/PureScript/Scope.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Utility functions for working with names in scope -- ----------------------------------------------------------------------------- @@ -25,6 +26,9 @@ import Language.PureScript.Names import Language.PureScript.CodeGen.JS.AST +-- |+-- Gather all used names appearing inside a value+-- usedNames :: (Data d) => d -> [Ident] usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB `extQ` namesJS) val where@@ -47,6 +51,9 @@ namesJS (JSFor name _ _ _) = [name] namesJS _ = [] +-- |+-- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@+-- unusedNames :: (Data d) => d -> [Ident] unusedNames val = let
src/Language/PureScript/Sugar.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Desugaring passes -- ----------------------------------------------------------------------------- @@ -25,6 +26,21 @@ import Language.PureScript.Sugar.BindingGroups as S import Language.PureScript.Sugar.TypeClasses as S +-- |+-- The desugaring pipeline proceeds as follows:+--+-- * Introduce type synonyms for type class dictionaries+--+-- * Rebracket user-defined binary operators+--+-- * Desugar do-notation using the @Prelude.Monad@ type class+--+-- * Desugar top-level case declarations into explicit case expressions+--+-- * Desugar type declarations into value declarations with explicit type annotations+--+-- * Group mutually recursive value and data declarations into binding groups.+-- desugar :: [Module] -> Either String [Module] desugar = desugarTypeClasses >=> rebracket
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -9,6 +9,8 @@ -- Portability : -- -- |+-- This module implements the desugaring pass which creates binding groups from sets of+-- mutually-recursive value declarations and mutually-recursive type declarations. -- ----------------------------------------------------------------------------- @@ -30,12 +32,21 @@ import Language.PureScript.Values import Language.PureScript.Types +-- |+-- Replace all sets of mutually-recursive declarations in a module with binding groups+-- createBindingGroupsModule :: [Module] -> Either String [Module] createBindingGroupsModule = mapM $ \(Module name ds) -> Module name <$> createBindingGroups ds +-- |+-- Collapse all binding groups in a module to individual declarations+-- collapseBindingGroupsModule :: [Module] -> [Module] collapseBindingGroupsModule = map $ \(Module name ds) -> Module name (collapseBindingGroups ds) +-- |+-- Replace all sets of mutually-recursive declarations with binding groups+-- createBindingGroups :: [Declaration] -> Either String [Declaration] createBindingGroups ds = do let values = filter isValueDecl ds@@ -54,6 +65,9 @@ filter isExternDecl ds ++ bindingGroupDecls +-- |+-- Collapse all binding groups to individual declarations+-- collapseBindingGroups :: [Declaration] -> [Declaration] collapseBindingGroups ds = concatMap go ds where
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -9,6 +9,8 @@ -- Portability : -- -- |+-- This module implements the desugaring pass which replaces top-level binders with+-- case expressions. -- ----------------------------------------------------------------------------- @@ -27,9 +29,14 @@ import Language.PureScript.Declarations import Language.PureScript.Scope +-- |+-- Replace all top-level binders in a module with case expressions.+-- desugarCasesModule :: [Module] -> Either String [Module] desugarCasesModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarCases ds-+-- |+-- Replace all top-level binders with case expressions.+-- desugarCases :: [Declaration] -> Either String [Declaration] desugarCases = fmap join . mapM toDecls . groupBy inSameGroup
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -9,6 +9,8 @@ -- Portability : -- -- |+-- This module implements the desugaring pass which replaces do-notation statements with+-- appropriate calls to (>>=) from the Prelude.Monad type class. -- ----------------------------------------------------------------------------- @@ -23,6 +25,10 @@ import Language.PureScript.Names import Language.PureScript.Scope +-- |+-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,+-- and all @DoNotationLet@ constructors with let expressions.+-- desugarDo :: (Data d) => d -> Either String d desugarDo = everywhereM (mkM replace) where
src/Language/PureScript/Sugar/Operators.hs view
@@ -9,7 +9,12 @@ -- Portability : -- -- |+-- This module implements the desugaring pass which reapplies binary operators based+-- on their fixity data and removes explicit parentheses. --+-- The value parser ignores fixity data when parsing binary operator applications, so+-- it is necessary to reorder them here.+-- ----------------------------------------------------------------------------- {-# LANGUAGE Rank2Types #-}@@ -33,6 +38,9 @@ import qualified Text.Parsec.Pos as P import qualified Text.Parsec.Expr as P +-- |+-- Remove explicit parentheses and reorder binary operator applications+-- rebracket :: [Module] -> Either String [Module] rebracket = go M.empty [] where
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -9,6 +9,8 @@ -- Portability : -- -- |+-- This module implements the desugaring pass which creates type synonyms for type class dictionaries+-- and dictionary expressions for type class instances. -- ----------------------------------------------------------------------------- @@ -38,6 +40,10 @@ type Desugar = StateT MemberMap (Either String) +-- |+-- Add type synonym declarations for type class dictionary types, and value declarations for type class+-- instance dictionary expressions.+-- desugarTypeClasses :: [Module] -> Either String [Module] desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule @@ -120,6 +126,9 @@ collect (TypeVar v) = [v] collect _ = [] +-- |+-- Generate a name for a type class dictionary, based on the module name, class name and type name+-- mkDictionaryValueName :: ModuleName -> Qualified ProperName -> Type -> Either String Ident mkDictionaryValueName mn cl ty = do tyStr <- typeToString mn ty@@ -135,6 +144,10 @@ typeToString mn (TypeApp ty' (TypeVar _)) = typeToString mn ty' typeToString a b = Left $ "Type class instance must be of the form T a1 ... an " ++ show (a, b) +-- |+-- Generate a name for a type class dictionary member, based on the module name, class name, type name and+-- member name+-- mkDictionaryEntryName :: ModuleName -> Qualified ProperName -> Type -> Ident -> Desugar Ident mkDictionaryEntryName mn name ty ident = do Ident dictName <- lift $ mkDictionaryValueName mn name ty
src/Language/PureScript/Sugar/TypeDeclarations.hs view
@@ -9,6 +9,8 @@ -- Portability : -- -- |+-- This module implements the desugaring pass which replaces top-level type declarations with+-- type annotations on the corresponding expression. -- ----------------------------------------------------------------------------- @@ -24,9 +26,15 @@ import Language.PureScript.Declarations import Language.PureScript.Values +-- |+-- Replace all top level type declarations in a module with type annotations+-- desugarTypeDeclarationsModule :: [Module] -> Either String [Module] desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds) -> Module name <$> desugarTypeDeclarations ds +-- |+-- Replace all top level type declarations with type annotations+-- desugarTypeDeclarations :: [Declaration] -> Either String [Declaration] desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' [] Nothing val : rest) | name == name' = desugarTypeDeclarations (ValueDeclaration name [] Nothing (TypedValue True val ty) : rest)
src/Language/PureScript/TypeChecker.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- The top-level type checker, which checks all declarations in a module. -- ----------------------------------------------------------------------------- @@ -88,6 +89,19 @@ addTypeClassDictionaries entries = do modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = entries ++ (typeClassDictionaries . checkEnv $ st) } } +-- |+-- Type check all declarations in a module+--+-- At this point, many declarations will have been desugared, but it is still necessary to+--+-- * Kind-check all types and add them to the @Environment@+--+-- * Type-check all values and add them to the @Environment@+--+-- * Bring type class instances into scope+--+-- * Process module imports+-- typeCheckAll :: ModuleName -> [Declaration] -> Check [Declaration] typeCheckAll _ [] = return [] typeCheckAll moduleName (d@(DataDeclaration name args dctors) : rest) = do
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- This module implements the kind checker -- ----------------------------------------------------------------------------- @@ -57,9 +58,15 @@ unknowns (FunKind k1 k2) = unknowns k1 ++ unknowns k2 unknowns _ = [] +-- |+-- Infer the kind of a single type+-- kindOf :: ModuleName -> Type -> Check Kind kindOf moduleName ty = fmap (\(k, s) -> apply s k) . runSubst (SubstContext moduleName) $ starIfUnknown <$> infer ty +-- |+-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors+-- kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k)) . runSubst (SubstContext moduleName) $ do tyCon <- fresh@@ -68,6 +75,9 @@ bindLocalTypeVariables moduleName dict $ solveTypes ts kargs tyCon +-- |+-- Simultaneously infer the kinds of several mutually recursive type constructors+-- kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind]) kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName) $ do synVars <- replicateM (length syns) fresh@@ -90,6 +100,9 @@ where tidyUp ((ks1, ks2), s) = (map starIfUnknown $ apply s ks1, map starIfUnknown $ apply s ks2) +-- |+-- Solve the set of kind constraints associated with the data constructors for a type constructor+-- solveTypes :: [Type] -> [Kind] -> Kind -> Subst Kind solveTypes ts kargs tyCon = do ks <- mapM infer ts@@ -97,11 +110,17 @@ forM_ ks $ \k -> k ~~ Star return tyCon +-- |+-- Default all unknown kinds to the Star kind of types+-- starIfUnknown :: Kind -> Kind starIfUnknown (KUnknown _) = Star starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) starIfUnknown k = k +-- |+-- Infer a kind for a type+-- infer :: Type -> Subst Kind infer Number = return Star infer String = return Star
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Monads for type checking and type inference and associated data types -- ----------------------------------------------------------------------------- @@ -37,31 +38,91 @@ import qualified Data.Map as M +-- |+-- The type of a name in the @Environment@+-- data NameKind+ -- |+ -- A value introduced as a binding in a module+ -- = Value+ -- |+ -- A foreign import+ -- | Extern ForeignImportType+ -- |+ -- An alias for a value in another module, introduced using an import declaration+ -- | Alias ModuleName Ident+ -- |+ -- A local name introduced using a lambda abstraction, variable introduction or binder+ -- | LocalVariable+ -- |+ -- A data constructor+ -- | DataConstructor deriving Show +-- |+-- The type of a type declaration+-- data TypeDeclarationKind+ -- |+ -- A data constructor+ -- = Data+ -- |+ -- A data type foreign import+ -- | ExternData+ -- |+ -- A type synonym+ -- | TypeSynonym+ -- |+ -- An alias for a type in another module, introduced using an import declaration+ -- | DataAlias ModuleName ProperName+ -- |+ -- A local type name introduced using a forall quantifier+ -- | LocalTypeVariable deriving Show -data Environment = Environment- { names :: M.Map (ModuleName, Ident) (Type, NameKind)+-- |+-- The @Environment@ defines all values and types which are currently in scope:+--+data Environment = Environment {+ -- |+ -- Value names currently in scope+ --+ names :: M.Map (ModuleName, Ident) (Type, NameKind)+ -- |+ -- Type names currently in scope+ -- , types :: M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind)+ -- |+ -- Data constructors currently in scope, along with their associated data type constructors+ -- , dataConstructors :: M.Map (ModuleName, ProperName) (Type, NameKind)+ -- |+ -- Type synonyms currently in scope+ -- , typeSynonyms :: M.Map (ModuleName, ProperName) ([String], Type)+ -- |+ -- Available type class dictionaries+ -- , typeClassDictionaries :: [TypeClassDictionaryInScope] } deriving (Show) +-- |+-- An empty environment with no values and no types defined+-- emptyEnvironment :: Environment emptyEnvironment = Environment M.empty M.empty M.empty M.empty [] +-- |+-- Temporarily bind a collection of names to values+-- bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind) -> m a -> m a bindNames newNames action = do orig <- get@@ -70,6 +131,9 @@ modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } } return a +-- |+-- Temporarily bind a collection of names to types+-- bindTypes :: (MonadState CheckState m) => M.Map (ModuleName, ProperName) (Kind, TypeDeclarationKind) -> m a -> m a bindTypes newNames action = do orig <- get@@ -78,6 +142,9 @@ modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } } return a +-- |+-- Temporarily make a collection of type class dictionaries available+-- withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a withTypeClassDictionaries entries action = do orig <- get@@ -86,17 +153,29 @@ modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } } return a +-- |+-- Get the currently available list of type class dictionaries+-- getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope] getTypeClassDictionaries = typeClassDictionaries . checkEnv <$> get +-- |+-- Temporarily bind a collection of names to local variables+-- bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type)] -> m a -> m a bindLocalVariables moduleName bindings action = bindNames (M.fromList $ flip map bindings $ \(name, ty) -> ((moduleName, name), (ty, LocalVariable))) action +-- |+-- Temporarily bind a collection of names to local type variables+-- bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a bindLocalTypeVariables moduleName bindings action = bindTypes (M.fromList $ flip map bindings $ \(name, k) -> ((moduleName, name), (k, LocalTypeVariable))) action +-- |+-- Lookup the type of a value by name in the @Environment@+-- lookupVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified Ident -> m Type lookupVariable currentModule (Qualified moduleName var) = do env <- getEnv@@ -104,6 +183,9 @@ Nothing -> throwError $ show var ++ " is undefined" Just (ty, _) -> return ty +-- |+-- Lookup the kind of a type by name in the @Environment@+-- lookupTypeVariable :: (Functor m, MonadState CheckState m, MonadError String m) => ModuleName -> Qualified ProperName -> m Kind lookupTypeVariable currentModule (Qualified moduleName name) = do env <- getEnv@@ -111,63 +193,120 @@ Nothing -> throwError $ "Type variable " ++ show name ++ " is undefined" Just (k, _) -> return k +-- |+-- Canonicalize an identifier by resolving any aliases introduced by module imports+-- canonicalize :: ModuleName -> Environment -> Qualified Ident -> (ModuleName, Ident) canonicalize _ _ (Qualified (Just mn) i) = (mn, i) canonicalize mn env (Qualified Nothing i) = case (mn, i) `M.lookup` names env of Just (_, Alias mn' i') -> (mn', i') _ -> (mn, i) +-- |+-- Canonicalize a type variable by resolving any aliases introduced by module imports+-- canonicalizeType :: ModuleName -> Environment -> Qualified ProperName -> (ModuleName, ProperName) canonicalizeType _ _ (Qualified (Just mn) nm) = (mn, nm) canonicalizeType mn env (Qualified Nothing nm) = case (mn, nm) `M.lookup` types env of Just (_, DataAlias mn' pn') -> (mn', pn') _ -> (mn, nm) -data CheckState = CheckState { checkEnv :: Environment- , checkNextVar :: Int- , checkNextDictName :: Int- }+-- |+-- State required for type checking:+--+data CheckState = CheckState {+ -- |+ -- The current @Environment@+ --+ checkEnv :: Environment+ -- |+ -- The next fresh unification variable name+ --+ , checkNextVar :: Int+ -- |+ -- The next type class dictionary name+ --+ , checkNextDictName :: Int+ } +-- |+-- The type checking monad, which provides the state of the type checker, and error reporting capabilities+-- newtype Check a = Check { unCheck :: StateT CheckState (Either String) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadState CheckState, MonadError String) +-- |+-- Get the current @Environment@+-- getEnv :: (Functor m, MonadState CheckState m) => m Environment getEnv = checkEnv <$> get +-- |+-- Update the @Environment#+-- putEnv :: (MonadState CheckState m) => Environment -> m () putEnv env = modify (\s -> s { checkEnv = env }) +-- |+-- Modify the @Environment@+-- modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m () modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) }) +-- |+-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.+-- runCheck :: Check a -> Either String (a, Environment) runCheck c = do (a, s) <- flip runStateT (CheckState emptyEnvironment 0 0) $ unCheck c return (a, checkEnv s) +-- |+-- Make an assertion, failing with an error message+-- guardWith :: (MonadError e m) => e -> Bool -> m () guardWith _ True = return () guardWith e False = throwError e +-- |+-- Rethrow an error with a more detailed error message in the case of failure+-- rethrow :: (MonadError e m) => (e -> e) -> m a -> m a rethrow f = flip catchError $ \e -> throwError (f e) +-- |+-- Generate new type class dictionary name+-- freshDictionaryName :: Check Int freshDictionaryName = do n <- checkNextDictName <$> get modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) } return n +-- |+-- A substitution maintains a mapping from unification variables to their values, ensuring that+-- the type of a unification variable matches the type of its value.+-- newtype Substitution = Substitution { runSubstitution :: forall t. (Unifiable t) => Unknown t -> t } instance Monoid Substitution where mempty = Substitution unknown s1 `mappend` s2 = Substitution $ \u -> apply s1 (apply s2 (unknown u)) +-- |+-- State for the substitution monad, which contains the current substitution+-- data SubstState = SubstState { substSubst :: Substitution } +-- |+-- Configuration for the substitution monad, constaining the current module+-- newtype SubstContext = SubstContext { substCurrentModule :: ModuleName } deriving (Show) +-- |+-- The substitution monad, which provides the means to unify values to generate a substitution, in addition to+-- the actions supported by the type checking monad @Check@.+-- newtype Subst a = Subst { unSubst :: ReaderT SubstContext (StateT SubstState Check) a } deriving (Functor, Monad, Applicative, MonadPlus, MonadReader SubstContext) @@ -177,28 +316,46 @@ deriving instance MonadError String Subst +-- |+-- Lift a computation in the @Check@ monad into the substitution monad.+-- liftCheck :: Check a -> Subst a liftCheck = Subst . lift . lift +-- |+-- Get the current substitution monad state+-- getSubstState :: Subst SubstState getSubstState = Subst . lift $ get +-- |+-- Run a computation in the substitution monad, generating a return value and the final substitution.+-- runSubst :: SubstContext -> Subst a -> Check (a, Substitution) runSubst context subst = do (a, s) <- flip runStateT (SubstState mempty) . flip runReaderT context . unSubst $ subst return (a, substSubst s) +-- |+-- Generate a substitution from a substitution function for a single type+-- substituteWith :: (Typeable t) => (Unknown t -> t) -> Substitution substituteWith f = Substitution $ \u -> fromMaybe (unknown u) $ do u1 <- cast u cast (f u1) +-- |+-- Substitute a single unification variable+-- substituteOne :: (Unifiable t) => Unknown t -> t -> Substitution substituteOne u t = substituteWith $ \u1 -> case u1 of u2 | u2 == u -> t | otherwise -> unknown u2 +-- |+-- Replace a unification variable with the specified value in the current substitution+-- replace :: (Unifiable t) => Unknown t -> t -> Subst () replace u t' = do sub <- substSubst <$> Subst get@@ -210,6 +367,9 @@ _ -> current ~~ t Subst . modify $ \s -> s { substSubst = substituteOne u t <> substSubst s } +-- |+-- Identifies types which support unification+-- class (Typeable t, Data t, Show t) => Unifiable t where unknown :: Unknown t -> t (~~) :: t -> t -> Subst ()@@ -224,21 +384,33 @@ apply s = map (apply s) unknowns = concatMap unknowns +-- |+-- Perform the occurs check, to make sure a unification variable does not occur inside a value+-- occursCheck :: (Unifiable t) => Unknown s -> t -> Subst () occursCheck (Unknown u) t = case isUnknown t of Nothing -> guardWith "Occurs check fails" (u `notElem` unknowns t) _ -> return () +-- |+-- Generate a fresh untyped unification variable+-- fresh' :: Subst Int fresh' = do n <- checkNextVar <$> get modify $ \s -> s { checkNextVar = succ (checkNextVar s) } return n +-- |+-- Generate a fresh unification variable at a specific type+-- fresh :: (Unifiable t) => Subst t fresh = unknown . Unknown <$> fresh' +-- |+-- Replace any unqualified names in a type wit their qualified versionss+-- qualifyAllUnqualifiedNames :: (Data d) => ModuleName -> Environment -> d -> d qualifyAllUnqualifiedNames mn env = everywhere (mkT go) where
src/Language/PureScript/TypeChecker/Synonyms.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor -- ----------------------------------------------------------------------------- @@ -28,6 +29,9 @@ import Control.Monad.Writer import Control.Monad.Error +-- |+-- Build a type substitution for a type synonym+-- buildTypeSubstitution :: Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> Type -> Either String (Maybe Type) buildTypeSubstitution env moduleName name n = go n [] where@@ -37,11 +41,17 @@ go m args (TypeApp f arg) = go (m - 1) (arg:args) f go _ _ _ = return Nothing +-- |+-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor+-- saturateTypeSynonym :: (Data d) => Environment -> ModuleName -> (ModuleName, ProperName) -> Int -> d -> Either String d saturateTypeSynonym env moduleName name n = everywhereM' (mkM replace) where replace t = fmap (fromMaybe t) $ buildTypeSubstitution env moduleName name n t +-- |+-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor+-- saturateAllTypeSynonyms :: (Data d) => Environment -> ModuleName -> [((ModuleName, ProperName), Int)] -> d -> Either String d saturateAllTypeSynonyms env moduleName syns d = foldM (\result (name, n) -> saturateTypeSynonym env moduleName name n result) d syns
src/Language/PureScript/TypeChecker/Types.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- This module implements the type checker -- ----------------------------------------------------------------------------- @@ -19,6 +20,25 @@ typesOf ) where +{-+ The following functions represent the corresponding type checking judgements:++ infer+ Synthesize a type for a value++ check+ Check a value has a given type++ checkProperties+ Check an object with a given type contains specified properties++ checkFunctionApplication+ Check a function of a given type returns a value of another type when applied to its arguments++ subsumes+ Check a type subsumes another type+-}+ import Data.List import Data.Maybe (maybeToList, isNothing, isJust, fromMaybe) import qualified Data.Data as D@@ -67,6 +87,9 @@ unknowns (RCons _ ty r) = unknowns ty ++ unknowns r unknowns _ = [] +-- |+-- Unify two types, updating the current substitution+-- unifyTypes :: Type -> Type -> Subst () unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do unifyTypes' t1 t2@@ -110,6 +133,13 @@ unifyTypes' r1 r2@REmpty = unifyRows r1 r2 unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "." +-- |+-- Unify two rows, updating the current substitution+--+-- Common labels are first identified, and unified. Remaining labels and types are unified with a+-- trailing row unification variable, if appropriate, otherwise leftover labels result in a unification+-- error.+-- unifyRows :: Type -> Type -> Subst () unifyRows r1 r2 = let@@ -136,9 +166,16 @@ unifyRows' [] (Skolem s1) [] (Skolem s2) | s1 == s2 = return () unifyRows' sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "." +-- |+-- Ensure type constructors are equal after canonicalization+-- typeConstructorsAreEqual :: Environment -> ModuleName -> Qualified ProperName -> Qualified ProperName -> Bool typeConstructorsAreEqual env moduleName = (==) `on` canonicalizeType moduleName env +-- |+-- Infer the types of multiple mutually-recursive values, and return elaborated values including+-- type class dictionaries and type annotations.+-- typesOf :: ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))] typesOf moduleName vals = do tys <- fmap (\(tys, s) -> map (\(ident, (val, ty)) -> (ident, (overTypes (apply s) val, apply s ty))) tys)@@ -173,19 +210,32 @@ return (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val' , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty)) +-- |+-- Check if a value contains a type annotation+-- isTyped :: (Ident, Value) -> (Ident, (Value, Maybe (Type, Bool))) isTyped (name, TypedValue checkType value ty) = (name, (value, Just (ty, checkType))) isTyped (name, value) = (name, (value, Nothing)) +-- |+-- Map a function over type annotations appearing inside a value+-- overTypes :: (Type -> Type) -> Value -> Value overTypes f = everywhere (mkT f) +-- |+-- Replace type class dictionary placeholders with inferred type class dictionaries+-- replaceTypeClassDictionaries :: ModuleName -> Value -> Check Value replaceTypeClassDictionaries mn = everywhereM (mkM go) where go (TypeClassDictionary constraint dicts) = entails mn dicts constraint go other = return other +-- |+-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,+-- return a type class dictionary reference.+-- entails :: ModuleName -> [TypeClassDictionaryInScope] -> (Qualified ProperName, Type) -> Check Value entails moduleName context goal@(className, ty) = do env <- getEnv@@ -211,6 +261,10 @@ canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm +-- |+-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),+-- and return a substitution from type variables to types which makes the type heads unify.+-- typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)] typeHeadsAreEqual _ _ String String = Just [] typeHeadsAreEqual _ _ Number Number = Just []@@ -222,6 +276,9 @@ typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1 typeHeadsAreEqual _ _ _ _ = Nothing +-- |+-- Ensure unsolved unification variables do not escape+-- escapeCheck :: Value -> Type -> Subst () escapeCheck value ty = do subst <- substSubst <$> getSubstState@@ -231,12 +288,18 @@ let unsolvedUnknowns = nub . unknowns $ apply subst t guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns +-- |+-- Find all type annotations occuring inside a value+-- findAllTypes :: Value -> [Type] findAllTypes = everything (++) (mkQ [] go) where go (TypedValue _ _ ty) = [ty] go _ = [] +-- |+-- Ensure skolem variables do not escape their scope+-- skolemEscapeCheck :: Type -> Check () skolemEscapeCheck ty = case something (mkQ Nothing findSkolems) ty of@@ -246,12 +309,21 @@ findSkolems (Skolem _) = return () findSkolems _ = mzero +-- |+-- Ensure a row contains no duplicate labels+-- setify :: Type -> Type setify = rowFromList . first (M.toList . M.fromList) . rowToList +-- |+-- \"Setify\" all rows occuring inside a value+-- setifyAll :: (D.Data d) => d -> d setifyAll = everywhere (mkT setify) +-- |+-- Replace outermost unsolved unification variables with named type variables+-- varIfUnknown :: Type -> Type varIfUnknown ty = let unks = nub $ unknowns ty@@ -262,18 +334,31 @@ typeToVar t = t in mkForAll (sort . map toName $ unks) ty' +-- |+-- Replace named type variables with types+-- replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id +-- |+-- Replace named type variables with new unification variables+-- replaceAllVarsWithUnknowns :: Type -> Subst Type replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns replaceAllVarsWithUnknowns ty = return ty +-- |+-- Replace a single type variable with a new unification variable+-- replaceVarWithUnknown :: String -> Type -> Subst Type replaceVarWithUnknown ident ty = do tu <- fresh return $ replaceTypeVars ident tu $ ty +-- |+-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate+-- better error messages during unification.+-- replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadReader SubstContext m, MonadError String m) => (D.Data d) => d -> m d replaceAllTypeSynonyms d = do env <- getEnv@@ -281,12 +366,18 @@ let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env either throwError return $ saturateAllTypeSynonyms env moduleName syns d +-- |+-- \"Desaturate\" @SaturatedTypeSynonym@s+-- desaturateAllTypeSynonyms :: (D.Data d) => d -> d desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym) where replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args replaceSaturatedTypeSynonym t = t +-- |+-- Replace a type synonym and its arguments with the aliased type+-- expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type expandTypeSynonym name args = do env <- getEnv@@ -295,12 +386,21 @@ Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body Nothing -> error "Type synonym was not defined" +-- |+-- Ensure a set of property names and value does not contain duplicate labels+-- ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m () ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps +-- |+-- Infer a type for a value, rethrowing any error to provide a more useful error message+-- infer :: Value -> Subst Value infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' val +-- |+-- Infer a type for a value+-- infer' :: Value -> Subst Value infer' v@(NumericLiteral _) = return $ TypedValue True v Number infer' v@(StringLiteral _) = return $ TypedValue True v String@@ -399,6 +499,9 @@ return $ TypedValue True val' ty infer' _ = error "Invalid argument to infer" +-- |+-- Infer the type of a property inside a record with a given type+-- inferProperty :: Type -> String -> Subst (Maybe Type) inferProperty (Object row) prop = do let (props, _) = rowToList row@@ -411,6 +514,9 @@ inferProperty replaced prop inferProperty _ _ = return Nothing +-- |+-- Infer the type of a unary operator application+-- inferUnary :: UnaryOperator -> Value -> Subst Value inferUnary op (TypedValue _ val valTy) = case fromMaybe (error "Invalid operator") $ lookup op unaryOps of@@ -419,6 +525,9 @@ return $ TypedValue True (Unary op val) resTy inferUnary _ _ = error "Invalid arguments to inferUnary" +-- |+-- Check the type of a unary operator application+-- checkUnary :: UnaryOperator -> Value -> Type -> Subst Value checkUnary op val res = case fromMaybe (error "Invalid operator") $ lookup op unaryOps of@@ -427,12 +536,18 @@ val' <- check val valTy return $ Unary op val' +-- |+-- Built-in unary operators+-- unaryOps :: [(UnaryOperator, (Type, Type))] unaryOps = [ (Negate, (Number, Number)) , (Not, (Boolean, Boolean)) , (BitwiseNot, (Number, Number)) ] +-- |+-- Infer the type of a binary operator application+-- inferBinary :: BinaryOperator -> Value -> Value -> Subst Value inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) | isEqualityTest op = do leftTy ~~ rightTy@@ -445,6 +560,9 @@ return $ TypedValue True (Binary op left right) resTy inferBinary _ _ _ = error "Invalid arguments to inferBinary" +-- |+-- Check the type of a binary operator application+-- checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst Value checkBinary op left right res | isEqualityTest op = do res ~~ Boolean@@ -460,11 +578,17 @@ right' <- check right valTy return $ Binary op left' right' +-- |+-- Check if a @BinaryOperator@ is an equality test+-- isEqualityTest :: BinaryOperator -> Bool isEqualityTest EqualTo = True isEqualityTest NotEqualTo = True isEqualityTest _ = False +-- |+-- Built-in binary operators+-- binaryOps :: [(BinaryOperator, (Type, Type))] binaryOps = [ (Add, (Number, Number)) , (Subtract, (Number, Number))@@ -486,6 +610,9 @@ , (GreaterThanOrEqualTo, (Number, Boolean)) ] +-- |+-- Infer the types of variables brought into scope by a binder+-- inferBinder :: Type -> Binder -> Subst (M.Map Ident Type) inferBinder _ NullBinder = return M.empty inferBinder val (StringBinder _) = val ~~ String >> return M.empty@@ -541,6 +668,9 @@ m <- inferBinder val binder return $ M.insert name val m +-- |+-- Check the types of the return values in a set of binders in a case statement+-- checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst [([Binder], Maybe Guard, Value)] checkBinders _ _ [] = return [] checkBinders nvals ret ((binders, grd, val):bs) = do@@ -556,14 +686,21 @@ rs <- checkBinders nvals ret bs return $ r : rs +-- |+-- Check that a local variable name is not already used+-- assignVariable :: Ident -> Subst () assignVariable name = do env <- checkEnv <$> get moduleName <- substCurrentModule <$> ask case M.lookup (moduleName, name) (names env) of- Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."+ Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists." _ -> return () +-- |+-- Check the type of the return values of a statement, returning whether or not the statement returns on+-- all code paths+-- checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type, Statement) checkStatement mass _ (VariableIntroduction name val) = do assignVariable name@@ -593,6 +730,9 @@ val' <- check val ret return (True, mass, Return val') +-- |+-- Check the type of an if-then-else statement+-- checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst (Bool, IfStatement) checkIfStatement mass ret (IfStatement val thens Nothing) = do val' <- check val Boolean@@ -604,12 +744,18 @@ (allCodePathsReturn2, elses') <- checkElseStatement mass ret elses return (allCodePathsReturn1 && allCodePathsReturn2, IfStatement val' thens' (Just elses')) +-- |+-- Check the type of an else statement+-- checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst (Bool, ElseStatement) checkElseStatement mass ret (Else elses) = do (allCodePathsReturn, _, elses') <- checkBlock mass ret elses return (allCodePathsReturn, Else elses') checkElseStatement mass ret (ElseIf ifst) = (id *** ElseIf) <$> checkIfStatement mass ret ifst +-- |+-- Check the type of the return value of a block of statements+-- checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type, [Statement]) checkBlock mass _ [] = return (False, mass, []) checkBlock mass ret (s:ss) = do@@ -622,11 +768,17 @@ (b, m, ss'') <- checkBlock mass1 ret ss' return (b, m, s':ss'') +-- |+-- Skolemize a type variable by replacing its instances with fresh skolem constants+-- skolemize :: String -> Type -> Subst Type skolemize ident ty = do tsk <- Skolem <$> fresh' return $ replaceTypeVars ident tsk ty +-- |+-- Check the type of a value, rethrowing errors to provide a better error message+-- check :: Value -> Type -> Subst Value check val ty = rethrow errorMessage $ check' val ty where@@ -638,6 +790,9 @@ ":\n" ++ msg +-- |+-- Check the type of a value+-- check' :: Value -> Type -> Subst Value check' val (ForAll idents ty) = do sk <- skolemize idents ty@@ -736,6 +891,11 @@ check val ty check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty +-- |+-- Check the type of a collection of named record fields+--+-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.+-- checkProperties :: [(String, Value)] -> Type -> Bool -> Subst [(String, Value)] checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where go [] [] REmpty = return []@@ -765,6 +925,9 @@ return $ (p, v') : ps'' go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row) +-- |+-- Check the type of a function application, rethrowing errors to provide a better error message+-- checkFunctionApplication :: Value -> Type -> [Value] -> Type -> Subst Value checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fn fnTy args ret where@@ -773,6 +936,9 @@ ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args) ++ ":\n" ++ msg +-- |+-- Check the type of a function application+-- checkFunctionApplication' :: Value -> Type -> [Value] -> Type -> Subst Value checkFunctionApplication' fn (Function argTys retTy) args ret = do guardWith "Incorrect number of function arguments" (length args == length argTys)@@ -800,12 +966,27 @@ ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args) ++ " does not yield a value of type " ++ prettyPrintType ret ++ "." +-- |+-- Check whether one type subsumes another, rethrowing errors to provide a better error message+-- subsumes :: Type -> Type -> Subst ()-subsumes (ForAll ident ty1) ty2 = do+subsumes ty1 ty2 = rethrow errorMessage $ subsumes' ty1 ty2+ where+ errorMessage msg = "Error checking that type "+ ++ prettyPrintType ty1+ ++ " subsumes type "+ ++ prettyPrintType ty2+ ++ ":\n" ++ msg++-- |+-- Check whether one type subsumes another+--+subsumes' :: Type -> Type -> Subst ()+subsumes' (ForAll ident ty1) ty2 = do replaced <- replaceVarWithUnknown ident ty1 replaced `subsumes` ty2-subsumes (Function args1 ret1) (Function args2 ret2) = do+subsumes' (Function args1 ret1) (Function args2 ret2) = do zipWithM_ subsumes args2 args1 ret1 `subsumes` ret2-subsumes ty1 ty2 = ty1 ~~ ty2+subsumes' ty1 ty2 = ty1 ~~ ty2
src/Language/PureScript/Types.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Data types for types -- ----------------------------------------------------------------------------- @@ -22,37 +23,100 @@ import Language.PureScript.Names import Language.PureScript.Unknown (Unknown(..)) +-- |+-- The type of types+-- data Type+ -- |+ -- A unification variable of type Type+ -- = TUnknown (Unknown Type)+ -- |+ -- Javascript numbers+ -- | Number+ -- |+ -- Javascript strings+ -- | String+ -- |+ -- Javascript booleans+ -- | Boolean+ -- |+ -- Javascript array type constructor+ -- | Array+ -- |+ -- Records, parameterized by a row of types+ -- | Object Type+ -- |+ -- A function, with zero or more arguments+ -- | Function [Type] Type+ -- |+ -- A named type variable+ -- | TypeVar String+ -- |+ -- A type constructor+ -- | TypeConstructor (Qualified ProperName)+ -- |+ -- A type application+ -- | TypeApp Type Type+ -- |+ -- A type synonym which is \"saturated\", i.e. fully applied+ -- | SaturatedTypeSynonym (Qualified ProperName) [Type]+ -- |+ -- Forall quantifier+ -- | ForAll String Type+ -- |+ -- A type with a set of type class constraints+ -- | ConstrainedType [(Qualified ProperName, Type)] Type+ -- |+ -- A skolem constant+ -- | Skolem Int+ -- |+ -- An empty row+ -- | REmpty+ -- |+ -- A non-empty row+ -- | RCons String Type Type deriving (Show, Eq, Data, Typeable) +-- |+-- Convert a row to a list of pairs of labels and types+-- rowToList :: Type -> ([(String, Type)], Type) rowToList (RCons name ty row) = let (tys, rest) = rowToList row in ((name, ty):tys, rest) rowToList r = ([], r) +-- |+-- Convert a list of labels and types to a row+-- rowFromList :: ([(String, Type)], Type) -> Type rowFromList ([], r) = r rowFromList ((name, t):ts, r) = RCons name t (rowFromList (ts, r)) +-- |+-- Check whether a type is a monotype+-- isMonoType :: Type -> Bool isMonoType (ForAll _ _) = False isMonoType ty = isPolyType ty +-- |+-- Check whather a type is a valid polytype+-- isPolyType :: Type -> Bool isPolyType (Object ps) = all isPolyType (map snd . fst $ rowToList ps) isPolyType (Function args ret) = all isPolyType args && isPolyType ret@@ -61,12 +125,21 @@ isPolyType (ForAll _ ty) = isPolyType ty isPolyType _ = True +-- |+-- Universally quantify a type+-- mkForAll :: [String] -> Type -> Type mkForAll = flip . foldl . flip $ ForAll +-- |+-- The empty record type+-- unit :: Type unit = Object REmpty +-- |+-- Replace a type variable, taking into account variable shadowing+-- replaceTypeVars :: (Data d) => String -> Type -> d -> d replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar) where
src/Language/PureScript/Unknown.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Data type for unification variables -- ----------------------------------------------------------------------------- @@ -18,6 +19,9 @@ import Data.Data +-- |+-- The type of typed unification variables+-- newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable)
src/Language/PureScript/Values.hs view
@@ -9,6 +9,7 @@ -- Portability : -- -- |+-- Data types for values, statements, binders and do notation -- ----------------------------------------------------------------------------- @@ -21,100 +22,369 @@ import Data.Data +-- |+-- A guard is just a boolean-valued expression that appears alongside a set of binders+-- type Guard = Value +-- |+-- Built-in unary operators+-- data UnaryOperator+ -- |+ -- Numeric negation+ -- = Negate+ -- |+ -- Boolean negation+ -- | Not+ -- |+ -- Bitwise negation+ -- | BitwiseNot+ -- |+ -- Numeric unary \'plus\'+ -- | Positive deriving (Show, Eq, Data, Typeable) +-- |+-- Built-in binary operators+-- data BinaryOperator+ -- |+ -- Numeric addition+ -- = Add+ -- |+ -- Numeric subtraction+ -- | Subtract+ -- |+ -- Numeric multiplication+ -- | Multiply+ -- |+ -- Numeric division+ -- | Divide+ -- |+ -- Remainder+ -- | Modulus+ -- |+ -- Generic equality test+ -- | EqualTo+ -- |+ -- Generic inequality test+ -- | NotEqualTo+ -- |+ -- Numeric less-than+ -- | LessThan+ -- |+ -- Numeric less-than-or-equal+ -- | LessThanOrEqualTo+ -- |+ -- Numeric greater-than+ -- | GreaterThan+ -- |+ -- Numeric greater-than-or-equal+ -- | GreaterThanOrEqualTo+ -- |+ -- Boolean and+ -- | And+ -- |+ -- Boolean or+ -- | Or+ -- |+ -- Bitwise and+ -- | BitwiseAnd+ -- |+ -- Bitwise or+ -- | BitwiseOr+ -- |+ -- Bitwise xor+ -- | BitwiseXor+ -- |+ -- Bitwise left shift+ -- | ShiftLeft+ -- |+ -- Bitwise right shift+ -- | ShiftRight+ -- |+ -- Bitwise right shift with zero-fill+ -- | ZeroFillShiftRight+ -- |+ -- String concatenation+ -- | Concat deriving (Show, Eq, Data, Typeable) +-- |+-- Data type for values+-- data Value+ -- |+ -- A numeric literal+ -- = NumericLiteral (Either Integer Double)+ -- |+ -- A string literal+ -- | StringLiteral String+ -- |+ -- A boolean literal+ -- | BooleanLiteral Bool+ -- |+ -- Unary operator application+ -- | Unary UnaryOperator Value+ -- |+ -- Binary operator application+ -- | Binary BinaryOperator Value Value+ -- |+ -- Binary operator application. During the rebracketing phase of desugaring, this data constructor+ -- will be removed.+ -- | BinaryNoParens (Qualified Ident) Value Value+ -- |+ -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor+ -- will be removed.+ -- | Parens Value+ -- |+ -- An array literal+ -- | ArrayLiteral [Value]+ -- |+ -- An array indexing expression+ -- | Indexer Value Value+ -- |+ -- An object literal+ -- | ObjectLiteral [(String, Value)]+ -- |+ -- An record property accessor expression+ -- | Accessor String Value+ -- |+ -- Partial record update+ -- | ObjectUpdate Value [(String, Value)]+ -- |+ -- Function introduction+ -- | Abs [Ident] Value+ -- |+ -- Function application+ -- | App Value [Value]+ -- |+ -- Variable+ -- | Var (Qualified Ident)+ -- |+ -- Conditional (if-then-else expression)+ -- | IfThenElse Value Value Value+ -- |+ -- A \"Block\" i.e. a collection of statements which evaluate to a value+ -- | Block [Statement]+ -- |+ -- A data constructor+ -- | Constructor (Qualified ProperName)+ -- |+ -- A case expression. During the case expansion phase of desugaring, top-level binders will get+ -- desugared into case expressions, hence the need for guards and multiple binders per branch here.+ -- | Case [Value] [([Binder], Maybe Guard, Value)]+ -- |+ -- A value with a type annotation+ -- | TypedValue Bool Value Type+ -- |+ -- A do-notation block+ -- | Do [DoNotationElement]+ -- |+ -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these+ -- placeholders will be replaced with actual expressions representing type classes dictionaries which+ -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and+ -- instance type, and the type class dictionaries in scope.+ -- | TypeClassDictionary (Qualified ProperName, Type) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable) +-- |+-- The type of a type class dictionary+-- data TypeClassDictionaryType+ -- |+ -- A regular type class dictionary+ -- = TCDRegular+ -- |+ -- A type class dictionary which is an alias for an imported dictionary from another module+ -- | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable) +-- |+-- Data representing a type class dictionary which is in scope+-- data TypeClassDictionaryInScope- = TypeClassDictionaryInScope { tcdName :: Qualified Ident- , tcdClassName :: Qualified ProperName- , tcdInstanceType :: Type- , tcdDependencies :: Maybe [(Qualified ProperName, Type)]- , tcdType :: TypeClassDictionaryType- } deriving (Show, Data, Typeable)+ = TypeClassDictionaryInScope {+ -- |+ -- The identifier with which the dictionary can be accessed at runtime+ --+ tcdName :: Qualified Ident+ -- |+ -- The name of the type class to which this type class instance applies+ --+ , tcdClassName :: Qualified ProperName+ -- |+ -- The type to which this type class instance applies+ --+ , tcdInstanceType :: Type+ -- |+ -- Type class dependencies which must be satisfied to construct this dictionary+ --+ , tcdDependencies :: Maybe [(Qualified ProperName, Type)]+ -- |+ -- The type of this dictionary+ --+ , tcdType :: TypeClassDictionaryType+ } deriving (Show, Data, Typeable) +-- |+-- A statement in a do-notation block+-- data DoNotationElement+ -- |+ -- A monadic value without a binder+ -- = DoNotationValue Value+ -- |+ -- A monadic value with a binder+ -- | DoNotationBind Binder Value+ -- |+ -- A let statement, i.e. a pure value with a binder+ -- | DoNotationLet Binder Value deriving (Show, Data, Typeable) +-- |+-- Data type for statements which can appear inside a @Block@ expression+-- data Statement+ -- |+ -- A variable introduction and initial assignment+ -- = VariableIntroduction Ident Value+ -- |+ -- A variable reassignment+ -- | Assignment Ident Value+ -- |+ -- A while loop+ -- | While Value [Statement]+ -- |+ -- A for loop+ -- | For Ident Value Value [Statement]+ -- |+ -- An if-then-else statement+ -- | If IfStatement+ -- |+ -- A return statement+ -- | Return Value deriving (Show, Data, Typeable) -data IfStatement = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable)+-- |+-- Data type for if-statements+--+data IfStatement+ -- |+ -- An if statement. Arguments are (in order): boolean condition, true branch, optional else branch.+ --+ = IfStatement Value [Statement] (Maybe ElseStatement) deriving (Show, Data, Typeable) +-- |+-- Data type for the else branch in an if-statement+-- data ElseStatement+ -- |+ -- An else branch+ -- = Else [Statement]+ -- |+ -- An else-if branch+ -- | ElseIf IfStatement deriving (Show, Data, Typeable) +-- |+-- Data type for binders+-- data Binder+ -- |+ -- Wildcard binder+ -- = NullBinder+ -- |+ -- A binder which matches a boolean literal+ -- | BooleanBinder Bool+ -- |+ -- A binder which matches a string literal+ -- | StringBinder String+ -- |+ -- A binder which matches a numeric literal+ -- | NumberBinder (Either Integer Double)+ -- |+ -- A binder which binds an identifier+ -- | VarBinder Ident+ -- |+ -- A binder which matches a data constructor with no argument+ -- | NullaryBinder (Qualified ProperName)+ -- |+ -- A binder which matches a data constructor with one argument+ -- | UnaryBinder (Qualified ProperName) Binder+ -- |+ -- A binder which matches a record and binds its properties+ -- | ObjectBinder [(String, Binder)]+ -- |+ -- A binder which matches an array and binds its elements+ -- | ArrayBinder [Binder]+ -- |+ -- A binder which matches an array and binds its head and tail+ -- | ConsBinder Binder Binder+ -- |+ -- A binder which binds its input to an identifier+ -- | NamedBinder Ident Binder deriving (Show, Data, Typeable)
tests/Main.hs view
@@ -12,6 +12,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE DoAndIfThenElse #-}+ module Main (main) where import qualified Language.PureScript as P@@ -19,41 +21,66 @@ import Data.List (isSuffixOf) import Control.Applicative import Control.Monad-import System.Exit (exitSuccess, exitFailure)+import System.Exit+import System.Process import System.FilePath (pathSeparator) import System.Directory (getCurrentDirectory, getDirectoryContents)+import System.Environment (getArgs)+import Text.Parsec (ParseError)+import qualified Paths_purescript as Paths import qualified System.IO.UTF8 as U import qualified Data.Map as M -compile :: FilePath -> IO (Either String P.Environment)-compile inputFile = do- modules <- P.runIndentParser P.parseModules <$> U.readFile inputFile+preludeFilename :: IO FilePath+preludeFilename = Paths.getDataFileName "libraries/prelude/prelude.purs"++readInput :: [FilePath] -> IO (Either ParseError [P.Module])+readInput inputFiles = fmap (fmap concat . sequence) $ forM inputFiles $ \inputFile -> do+ text <- U.readFile inputFile+ return $ P.runIndentParser P.parseModules text++compile :: P.Options -> [FilePath] -> IO (Either String String)+compile opts inputFiles = do+ modules <- readInput inputFiles case modules of Left parseError -> do return (Left $ show parseError) Right ms -> do- case P.compile P.defaultOptions ms of+ case P.compile opts ms of Left typeError -> do return (Left typeError)- Right (_, _, env) -> do- return (Right env)+ Right (js, _, _) -> do+ return (Right js) -assert :: FilePath -> (Either String P.Environment -> Maybe String) -> IO ()-assert inputFile f = do- e <- compile inputFile- case f e of- Just err -> exitFailure+assert :: P.Options -> [FilePath] -> (Either String String -> IO (Maybe String)) -> IO ()+assert opts inputFiles f = do+ e <- compile opts inputFiles+ maybeErr <- f e+ case maybeErr of+ Just err -> putStrLn err >> exitFailure Nothing -> return () assertCompiles :: FilePath -> IO () assertCompiles inputFile = do putStrLn $ "assert " ++ inputFile ++ " compiles successfully"- assert inputFile $ either Just (const Nothing)+ prelude <- preludeFilename+ assert (P.defaultOptions { P.optionsRunMain = True }) [prelude, inputFile] $ either (return . Just) $ \js -> do+ args <- getArgs+ if "--run-js" `elem` args+ then do+ (exitCode, out, err) <- readProcessWithExitCode "nodejs" [] js+ case exitCode of+ ExitSuccess -> putStrLn out >> return Nothing+ ExitFailure code -> return $ Just err+ else return Nothing assertDoesNotCompile :: FilePath -> IO () assertDoesNotCompile inputFile = do putStrLn $ "assert " ++ inputFile ++ " does not compile"- assert inputFile $ either (const Nothing) (const $ Just "Should not have compiled")+ assert P.defaultOptions [inputFile] $ \e ->+ case e of+ Left _ -> return Nothing+ Right _ -> return $ Just "Should not have compiled" main :: IO () main = do