diff options
| author | PhilFreeman <> | 2014-01-28 06:32:00 (GMT) |
|---|---|---|
| committer | hdiff <hdiff@hdiff.luite.com> | 2014-01-28 06:32:00 (GMT) |
| commit | b9baaa3d13ed8d5ac0817292097b395775c0742e (patch) | |
| tree | 2da5f50a43e679acaae14a0546535ceae1871977 | |
| parent | e29a60804b4acdeb46626233ee4001384978dff1 (diff) | |
version 0.3.40.3.4
46 files changed, 1854 insertions, 172 deletions
diff --git a/libraries/prelude/prelude.purs b/libraries/prelude/prelude.purs index 44d2203..414c4fd 100644 --- a/libraries/prelude/prelude.purs +++ b/libraries/prelude/prelude.purs @@ -49,8 +49,9 @@ module Maybe where 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 @@ module Either where 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 @@ module Arrays where \ return xs.length; \ \}" :: forall a. [a] -> Number - foreign import indexOf :: forall a. [a] -> a -> Number - - foreign import lastIndexOf :: forall a. [a] -> a -> Number - - foreign import concat :: forall a. [a] -> [a] -> [a] - - foreign import join :: [String] -> String - - foreign import joinWith :: [String] -> String -> String - - foreign import push :: forall a. [a] -> a -> [a] - - foreign import reverse :: forall a. [a] -> [a] - - foreign import shift :: forall a. [a] -> [a] - - foreign import slice :: forall a. Number -> Number -> [a] -> [a] - - foreign import sort :: forall a. [a] -> [a] - - foreign import splice :: forall a. Number -> Number -> [a] -> [a] -> [a] + foreign import indexOf "function indexOf(l) {\ + \ return function (e) {\ + \ return l.indexOf(e);\ + \ };\ + \}" :: 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 "function concat(l1) {\ + \ return function (l2) {\ + \ return l1.concat(l2);\ + \ };\ + \}" :: forall a. [a] -> [a] -> [a] + + foreign import join "function join(l) {\ + \ return l.join();\ + \}" :: [String] -> String + + foreign import joinWith "function joinWith(l) {\ + \ return function (s) {\ + \ return l.join(s);\ + \ };\ + \}" :: [String] -> String -> String + + 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 "function reverse(l) {\ + \ var l1 = l.slice();\ + \ l1.reverse(); \ + \ return l1;\ + \}" :: 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 "function slice(s) {\ + \ return function(e) {\ + \ return function (l) {\ + \ return l.slice(s, e);\ + \ };\ + \ };\ + \}" :: forall a. Number -> Number -> [a] -> [a] + + foreign import sort "function sort(l) {\ + \ var l1 = l.slice();\ + \ l.sort();\ + \ return l1;\ + \}" :: forall 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 @@ module Arrays where 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 @@ module String where \ return s.length;\ \}" :: String -> Number - foreign import charAt :: Number -> String -> String - - foreign import indexOfS :: String -> String -> Number - - foreign import lastIndexOfS :: String -> String -> Number - - foreign import localeCompare :: String -> String -> Number - - foreign import replace :: String -> String -> String -> String - - foreign import sliceS :: Number -> Number -> String -> String - - foreign import split :: String -> String -> [String] - - foreign import substr :: Number -> Number -> String -> String - - foreign import substring :: Number -> Number -> String -> String - - foreign import toLower :: String -> String - - foreign import toUpper :: String -> String - - foreign import trim :: String -> String + foreign import charAt "function charAt(i) {\ + \ return function(s) {\ + \ return s.charAt(i); \ + \ };\ + \}" :: Number -> String -> String + + foreign import indexOfS "function indexOfS(s1) {\ + \ return function(s2) {\ + \ return s2.indexOf(s2);\ + \ }; \ + \}" :: String -> String -> Number + + foreign import lastIndexOfS "function lastIndexOfS(s1) {\ + \ return function(s2) {\ + \ return s2.lastIndexOf(s2);\ + \ };\ + \}" :: String -> String -> Number + + foreign import localeCompare "function localeCompare(s1) {\ + \ return function(s2) { \ + \ return s1.localeCompare(s2);\ + \ };\ + \}" :: String -> String -> Number + + foreign import replace "function replace(s1) {\ + \ return function(s2) {\ + \ return function(s3) {\ + \ return s3.replace(s1, s2);\ + \ };\ + \ };\ + \}" :: String -> String -> 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 "function split(sep) {\ + \ return function(s) {\ + \ return s.split(s);\ + \ };\ + \}" :: String -> 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 "function substring(n1) {\ + \ return function(n2) {\ + \ return function(s) {\ + \ return s.substring(n1, n2);\ + \ };\ + \ };\ + \}" :: Number -> Number -> String -> String + + foreign import toLower "function toLower(s) {\ + \ return s.toLower();\ + \}" :: String -> String + + foreign import toUpper "function toUpper(s) {\ + \ return s.toUpper();\ + \}" :: 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 test :: Regex -> String -> Boolean - - foreign import match :: Regex -> String -> [String] - - foreign import replaceR :: Regex -> String -> String -> String - - foreign import search :: Regex -> String -> Number + foreign import regex "function regex(s1) {\ + \ return function(s2) {\ + \ return new Regex(s1, s2);\ + \ };\ + \}" :: String -> String -> Regex + + foreign import test "function test(r) {\ + \ return function (s) { \ + \ return r.test(s);\ + \ };\ + \}" :: Regex -> String -> Boolean + + foreign import match "function match(r) {\ + \ return function (s) {\ + \ return s.match(r); \ + \ };\ + \}" :: Regex -> 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 "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 @@ module Global where foreign import decodeURI :: String -> String + instance Prelude.Show Number where + show = numberToString + module Math where type Math = @@ -277,19 +421,31 @@ module Math where , 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 @@ module Errors where 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 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 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 module IORef where @@ -313,11 +483,25 @@ module IORef where foreign import data IORef :: * -> * - foreign import newIORef :: 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 writeIORef :: forall s r. IORef s -> s -> Eff (ref :: Ref | r) {} + foreign import newIORef "function newIORef(val) {\ + \ return function () {\ + \ return { value: val };\ + \ };\ + \}" :: forall s r. s -> Eff (ref :: Ref | r) (IORef 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 "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 @@ module Trace where 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 @@ module ST where foreign import data STRef :: * -> * -> * - foreign import newSTRef :: 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 modifySTRef :: 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 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 "function readSTRef(ref) {\ + \ return function() {\ + \ return ref.value;\ + \ };\ + \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a + + 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 "function runST(f) {\ + \ return f;\ + \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a diff --git a/purescript.cabal b/purescript.cabal index a3b3923..56778d8 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -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 @@ executable psci 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 diff --git a/src/Data/Generics/Extras.hs b/src/Data/Generics/Extras.hs index 02db199..80ffede 100644 --- a/src/Data/Generics/Extras.hs +++ b/src/Data/Generics/Extras.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Additional SYB combinators -- ----------------------------------------------------------------------------- @@ -18,6 +19,9 @@ module Data.Generics.Extras where 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 diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs index 45c9d75..8bff204 100644 --- a/src/Language/PureScript.hs +++ b/src/Language/PureScript.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- The main compiler module -- ----------------------------------------------------------------------------- @@ -32,6 +33,23 @@ import Control.Monad (when, forM) 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 diff --git a/src/Language/PureScript/CodeGen.hs b/src/Language/PureScript/CodeGen.hs index a5bee01..0540020 100644 --- a/src/Language/PureScript/CodeGen.hs +++ b/src/Language/PureScript/CodeGen.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs index 7fce595..e6d6c9f 100644 --- a/src/Language/PureScript/CodeGen/Externs.hs +++ b/src/Language/PureScript/CodeGen/Externs.hs @@ -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.Pretty 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" ++ diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 158dd67..4fed12e 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -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.CodeGen.JS.AST as AST 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 @@ moduleToJs opts (Module pname@(ProperName name) decls) env = 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)), diff --git a/src/Language/PureScript/CodeGen/JS/AST.hs b/src/Language/PureScript/CodeGen/JS/AST.hs index 7d531cf..58a8fa9 100644 --- a/src/Language/PureScript/CodeGen/JS/AST.hs +++ b/src/Language/PureScript/CodeGen/JS/AST.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Data types for the intermediate simplified-Javascript AST -- ----------------------------------------------------------------------------- @@ -21,36 +22,124 @@ import Language.PureScript.Values 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) - - diff --git a/src/Language/PureScript/CodeGen/Monad.hs b/src/Language/PureScript/CodeGen/Monad.hs index 0e8b165..4fa9cbd 100644 --- a/src/Language/PureScript/CodeGen/Monad.hs +++ b/src/Language/PureScript/CodeGen/Monad.hs @@ -9,6 +9,9 @@ -- Portability : -- -- | +-- Code generation monad +-- +-- This monad provides a supply of fresh names which can be used to create variables. -- ----------------------------------------------------------------------------- @@ -20,11 +23,20 @@ import Control.Monad.State 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 diff --git a/src/Language/PureScript/CodeGen/Optimize.hs b/src/Language/PureScript/CodeGen/Optimize.hs index 509a776..5308425 100644 --- a/src/Language/PureScript/CodeGen/Optimize.hs +++ b/src/Language/PureScript/CodeGen/Optimize.hs @@ -9,6 +9,23 @@ -- 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 -- ----------------------------------------------------------------------------- @@ -28,6 +45,9 @@ import Language.PureScript.Sugar.TypeClasses (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 @@ isReassigned var1 = everything (||) (mkQ False check) 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,9 +92,17 @@ isUsed var1 = everything (||) (mkQ False check) 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 @@ -93,7 +121,9 @@ inlineVariables = everywhere (mkT removeFromBlock) 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 diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs index 71c543e..3df4ec3 100644 --- a/src/Language/PureScript/Declarations.hs +++ b/src/Language/PureScript/Declarations.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : -- --- | +-- | Data types for modules and declarations -- ----------------------------------------------------------------------------- @@ -24,59 +24,143 @@ import Language.PureScript.CodeGen.JS.AST 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 diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 92f9f4e..9089d84 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -19,9 +19,27 @@ module Language.PureScript.Kinds where 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) diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs index ecf917b..bdc82f0 100644 --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : -- --- | +-- | Provides the ability to sort modules based on module dependencies -- ----------------------------------------------------------------------------- @@ -27,18 +27,19 @@ import Language.PureScript.Names 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 @@ usedModules = nub . everything (++) (mkQ [] qualifiedIdents `extQ` qualifiedProp 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 diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 219f5e5..abe5893 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Data types for names -- ----------------------------------------------------------------------------- @@ -18,28 +19,51 @@ module Language.PureScript.Names where 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) diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs index 2065656..ce24c22 100644 --- a/src/Language/PureScript/Options.hs +++ b/src/Language/PureScript/Options.hs @@ -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 diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs index 503cf03..43fb8d4 100644 --- a/src/Language/PureScript/Parser.hs +++ b/src/Language/PureScript/Parser.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index bb64947..43b283c 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Constants, and utility functions to be used when parsing -- ----------------------------------------------------------------------------- @@ -25,6 +26,9 @@ import qualified Text.Parsec.Token as PT import Language.PureScript.Names +-- | +-- A list of reserved identifiers +-- reservedNames :: [String] reservedNames = [ "case" , "of" @@ -76,28 +80,52 @@ reservedNames = [ "case" , "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 @@ langDef = PT.LanguageDef , 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 @@ buildPostfixParser fs first = do 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 @@ mark p = do 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) "" diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index c7ef5c8..9fee7cc 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Parsers for module definitions and declarations -- ----------------------------------------------------------------------------- @@ -120,6 +121,9 @@ parseTypeInstanceDeclaration = do 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 @@ parseDeclaration = P.choice , 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 @@ parseModule = do 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 diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs index ab07993..79a84d2 100644 --- a/src/Language/PureScript/Parser/JS.hs +++ b/src/Language/PureScript/Parser/JS.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- A parser for a small fragment of Javascript -- ----------------------------------------------------------------------------- @@ -99,6 +100,9 @@ binary op s f = P.Infix (P.try $ C.reservedOp s >> return (JSBinary op)) f 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 diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index cb88e52..9e06c65 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- A parser for kinds -- ----------------------------------------------------------------------------- @@ -34,7 +35,9 @@ parseTypeAtom = indented *> P.choice (map P.try [ parseStar , parseBang , parens parseKind ]) - +-- | +-- Parse a kind +-- parseKind :: P.Parsec String ParseState Kind parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind" where diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs index e20cb1d..f66516c 100644 --- a/src/Language/PureScript/Parser/State.hs +++ b/src/Language/PureScript/Parser/State.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- State for the parser monad -- ----------------------------------------------------------------------------- @@ -16,7 +17,14 @@ module Language.PureScript.Parser.State where 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 diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs index e6b1984..970e39a 100644 --- a/src/Language/PureScript/Parser/Types.hs +++ b/src/Language/PureScript/Parser/Types.hs @@ -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 @@ parseAnyType = (P.buildExpressionParser operators . buildPostfixParser postfixTa 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 diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs index 5f70a77..7ef3b65 100644 --- a/src/Language/PureScript/Parser/Values.hs +++ b/src/Language/PureScript/Parser/Values.hs @@ -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 @@ parseDoNotationElement = P.choice , parseDoNotationLet , P.try (DoNotationValue <$> parseValue) ] +-- | +-- Parse a value +-- parseValue :: P.Parsec String ParseState Value parseValue = (buildExpressionParser operators @@ -212,6 +216,9 @@ parseElseStatement = C.reserved "else" >> (ElseIf <$> parseIfStatement 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 @@ parseBinderAtom = P.choice (map P.try , 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 @@ parseBinderNoParens = P.choice (map P.try , parseObjectBinder , parseArrayBinder , C.parens parseBinder ]) P.<?> "binder" - +-- | +-- Parse a guard +-- parseGuard :: P.Parsec String ParseState Guard parseGuard = C.indented *> C.pipe *> C.indented *> parseValue diff --git a/src/Language/PureScript/Pretty.hs b/src/Language/PureScript/Pretty.hs index a5c03c5..7d569c5 100644 --- a/src/Language/PureScript/Pretty.hs +++ b/src/Language/PureScript/Pretty.hs @@ -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 -- ----------------------------------------------------------------------------- diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs index d9cf69d..82d6592 100644 --- a/src/Language/PureScript/Pretty/Common.hs +++ b/src/Language/PureScript/Pretty/Common.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Common pretty-printing utility functions -- ----------------------------------------------------------------------------- @@ -25,50 +26,107 @@ import Control.Arrow ((***), (<+>)) 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 diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs index 02ebf1c..de85700 100644 --- a/src/Language/PureScript/Pretty/JS.hs +++ b/src/Language/PureScript/Pretty/JS.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Pretty printer for the Javascript AST -- ----------------------------------------------------------------------------- @@ -30,9 +31,15 @@ import Control.Monad.State 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 @@ withIndent action = do 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 @@ binary op str = AssocR match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2) 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 diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index aa358fe..cf5f8a2 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Pretty printer for kinds -- ----------------------------------------------------------------------------- @@ -43,6 +44,9 @@ funKind = mkPattern match 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 diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs index c8fbfac..5f2da8d 100644 --- a/src/Language/PureScript/Pretty/Types.hs +++ b/src/Language/PureScript/Pretty/Types.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Pretty printer for Types -- ----------------------------------------------------------------------------- @@ -44,6 +45,9 @@ typeLiterals = mkPattern match 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 @@ function = mkPattern match 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 diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index a2b5c5e..554edd8 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Pretty printer for values -- ----------------------------------------------------------------------------- @@ -113,6 +114,9 @@ prettyPrintDoNotationElement (DoNotationValue val) = prettyPrintValue val 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 @@ prettyPrintBinderAtom = mkPattern match 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 diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs index 6665e26..c4b4164 100644 --- a/src/Language/PureScript/Scope.hs +++ b/src/Language/PureScript/Scope.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Utility functions for working with names in scope -- ----------------------------------------------------------------------------- @@ -25,6 +26,9 @@ import Language.PureScript.Values 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 @@ usedNames val = nub $ everything (++) (mkQ [] namesV `extQ` namesS `extQ` namesB 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 diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 92f1b81..0a1c001 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Desugaring passes -- ----------------------------------------------------------------------------- @@ -25,6 +26,21 @@ import Language.PureScript.Sugar.TypeDeclarations as S 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 diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index 006bcfd..de04561 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -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.Names 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 @@ createBindingGroups ds = do filter isExternDecl ds ++ bindingGroupDecls +-- | +-- Collapse all binding groups to individual declarations +-- collapseBindingGroups :: [Declaration] -> [Declaration] collapseBindingGroups ds = concatMap go ds where diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs index 6b1ea46..bc8449e 100644 --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -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.Values 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 diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs index 6390ceb..f6d285e 100644 --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -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.Values 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 diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs index 22cde6e..acda4ff 100644 --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -9,6 +9,11 @@ -- 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. -- ----------------------------------------------------------------------------- @@ -33,6 +38,9 @@ import qualified Text.Parsec as P 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 diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs index 951ed0c..b7bd429 100644 --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -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 MemberMap = M.Map (ModuleName, ProperName) (String, [(String, Type)]) 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 @@ quantify ty' = foldr ForAll ty' tyVars 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 (TypeConstructor ty') = return $ qualifiedToString mn ty' 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 diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs index 1045ac5..53c54fc 100644 --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -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 Control.Monad (forM) 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) diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 8146fc5..fced1d9 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- The top-level type checker, which checks all declarations in a module. -- ----------------------------------------------------------------------------- @@ -88,6 +89,19 @@ addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check () 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 diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index 5263a7f..1947876 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- This module implements the kind checker -- ----------------------------------------------------------------------------- @@ -57,9 +58,15 @@ instance Unifiable Kind where 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 @@ kindsOf moduleName name args ts = fmap (starIfUnknown . (\(k, s) -> apply s k)) 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 @@ kindsOfAll moduleName syns tys = fmap tidyUp . runSubst (SubstContext moduleName 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 @@ solveTypes ts kargs tyCon = do 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 diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs index 1ab2ea0..2d0e856 100644 --- a/src/Language/PureScript/TypeChecker/Monad.hs +++ b/src/Language/PureScript/TypeChecker/Monad.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Monads for type checking and type inference and associated data types -- ----------------------------------------------------------------------------- @@ -37,31 +38,91 @@ import Control.Arrow ((***)) 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 @@ bindNames newNames action = do 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 @@ bindTypes newNames action = do 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 @@ withTypeClassDictionaries entries action = do 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 @@ lookupVariable currentModule (Qualified moduleName var) = do 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 @@ lookupTypeVariable currentModule (Qualified moduleName name) = do 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 @@ instance MonadState CheckState Subst where 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 @@ replace u t' = do _ -> 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 @@ instance (Unifiable a) => Unifiable [a] where 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 diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 92d99bb..9c33c45 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor -- ----------------------------------------------------------------------------- @@ -28,6 +29,9 @@ import Data.Generics.Extras 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 @@ buildTypeSubstitution env moduleName name n = go n [] 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 diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index b334154..0e4127b 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- This module implements the type checker -- ----------------------------------------------------------------------------- @@ -19,6 +20,25 @@ module Language.PureScript.TypeChecker.Types ( 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 @@ instance Unifiable Type where 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 t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 + 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 r1 r2 = 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 @@ typesOf moduleName vals = do 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 @@ entails moduleName context goal@(className, ty) = do 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 (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) < 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 @@ escapeCheck value ty = do 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 @@ skolemEscapeCheck ty = 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 @@ varIfUnknown ty = 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 @@ replaceAllTypeSynonyms d = do 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 @@ expandTypeSynonym name args = do 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 @@ infer' (TypedValue checkType val ty) = do 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 (ForAll ident ty) prop = do 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 @@ inferUnary op (TypedValue _ val valTy) = 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 @@ checkUnary op val res = 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 @@ inferBinary op left@(TypedValue _ _ leftTy) right@(TypedValue _ _ rightTy) = 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 @@ checkBinary op left right res = 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 @@ binaryOps = [ (Add, (Number, Number)) , (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 @@ inferBinder val (NamedBinder name binder) = do 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 @@ checkBinders nvals ret ((binders, grd, val):bs) = do 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 @@ checkStatement mass ret (Return val) = do 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 @@ checkIfStatement mass ret (IfStatement val thens (Just elses)) = do (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 @@ checkBlock mass ret (s:ss) = do (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 @@ check val ty = rethrow errorMessage $ check' val ty ":\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 (SaturatedTypeSynonym name args) = do 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 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where 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 @@ checkFunctionApplication fn fnTy args ret = rethrow errorMessage $ checkFunction ++ " 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 @@ checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of ++ " 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 diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs index a7ad809..9df92a6 100644 --- a/src/Language/PureScript/Types.hs +++ b/src/Language/PureScript/Types.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Data types for types -- ----------------------------------------------------------------------------- @@ -22,37 +23,100 @@ import Data.Generics (mkT, mkQ, everywhereBut) 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 (SaturatedTypeSynonym _ args) = all isPolyType args 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 diff --git a/src/Language/PureScript/Unknown.hs b/src/Language/PureScript/Unknown.hs index 96e102b..a5f8e91 100644 --- a/src/Language/PureScript/Unknown.hs +++ b/src/Language/PureScript/Unknown.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Data type for unification variables -- ----------------------------------------------------------------------------- @@ -18,6 +19,9 @@ module Language.PureScript.Unknown where import Data.Data +-- | +-- The type of typed unification variables +-- newtype Unknown t = Unknown { runUnknown :: Int } deriving (Show, Eq, Ord, Data, Typeable) diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs index 0051003..3c7bea1 100644 --- a/src/Language/PureScript/Values.hs +++ b/src/Language/PureScript/Values.hs @@ -9,6 +9,7 @@ -- Portability : -- -- | +-- Data types for values, statements, binders and do notation -- ----------------------------------------------------------------------------- @@ -21,100 +22,369 @@ import Language.PureScript.Names 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) diff --git a/tests/Main.hs b/tests/Main.hs index d008b74..5fc4b34 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -12,6 +12,8 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE DoAndIfThenElse #-} + module Main (main) where import qualified Language.PureScript as P @@ -19,41 +21,66 @@ import qualified Language.PureScript as P 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 |