summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/failing/InfiniteKind.purs5
-rw-r--r--examples/failing/InfiniteType.purs5
-rw-r--r--examples/failing/OrphanInstance.purs12
-rw-r--r--psc/Main.hs18
-rw-r--r--psci/PSCi.hs2
-rw-r--r--psci/Types.hs4
-rw-r--r--psci/tests/data/Sample.purs0
-rw-r--r--purescript.cabal9
-rw-r--r--src/Language/PureScript/AST/Declarations.hs22
-rw-r--r--src/Language/PureScript/AST/Traversals.hs13
-rw-r--r--src/Language/PureScript/Constants.hs14
-rw-r--r--src/Language/PureScript/Errors.hs38
-rw-r--r--src/Language/PureScript/Make.hs66
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs17
-rw-r--r--src/Language/PureScript/Parser/JS.hs6
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs1
-rw-r--r--src/Language/PureScript/Pretty/JS.hs1
-rw-r--r--src/Language/PureScript/Publish/ErrorsWarnings.hs4
-rw-r--r--src/Language/PureScript/Sugar.hs2
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs2
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs3
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses/Deriving.hs229
-rw-r--r--src/Language/PureScript/TypeChecker.hs18
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs1
-rw-r--r--tests/Main.hs65
-rw-r--r--tests/support/bower.json11
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Class.purs24
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Console.js18
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Console.purs18
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Unsafe.js8
-rw-r--r--tests/support/flattened/Control-Monad-Eff-Unsafe.purs10
-rw-r--r--tests/support/flattened/Control-Monad-Eff.js62
-rw-r--r--tests/support/flattened/Control-Monad-Eff.purs67
-rw-r--r--tests/support/flattened/Control-Monad-ST.js38
-rw-r--r--tests/support/flattened/Control-Monad-ST.purs42
-rw-r--r--tests/support/flattened/Data-Function.js233
-rw-r--r--tests/support/flattened/Data-Function.purs113
-rw-r--r--tests/support/flattened/Prelude.js222
-rw-r--r--tests/support/flattened/Prelude.purs860
-rw-r--r--tests/support/flattened/Test-Assert.js27
-rw-r--r--tests/support/flattened/Test-Assert.purs46
-rw-r--r--tests/support/package.json7
-rw-r--r--tests/support/setup.js22
43 files changed, 484 insertions, 1901 deletions
diff --git a/examples/failing/InfiniteKind.purs b/examples/failing/InfiniteKind.purs
new file mode 100644
index 0000000..c2f0e1c
--- /dev/null
+++ b/examples/failing/InfiniteKind.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith InfiniteKind
+
+module Main where
+
+data F a = F (a a)
diff --git a/examples/failing/InfiniteType.purs b/examples/failing/InfiniteType.purs
new file mode 100644
index 0000000..28cd889
--- /dev/null
+++ b/examples/failing/InfiniteType.purs
@@ -0,0 +1,5 @@
+-- @shouldFailWith InfiniteType
+
+module Main where
+
+f a = a a
diff --git a/examples/failing/OrphanInstance.purs b/examples/failing/OrphanInstance.purs
new file mode 100644
index 0000000..878c82a
--- /dev/null
+++ b/examples/failing/OrphanInstance.purs
@@ -0,0 +1,12 @@
+-- @shouldFailWith OrphanInstance
+module Class where
+
+ class C a where
+ op :: a -> a
+
+module Test where
+
+ import Class
+
+ instance cBoolean :: C Boolean where
+ op a = a
diff --git a/psc/Main.hs b/psc/Main.hs
index f42f523..4ac18c0 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -52,12 +52,12 @@ data InputOptions = InputOptions
compile :: PSCMakeOptions -> IO ()
compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = do
- input <- concat <$> mapM glob inputGlob
+ input <- globWarningOnMisses warnFileTypeNotFound inputGlob
when (null input) $ do
hPutStrLn stderr "psc: No input files."
exitFailure
moduleFiles <- readInput (InputOptions input)
- inputForeign <- concat <$> mapM glob inputForeignGlob
+ inputForeign <- globWarningOnMisses warnFileTypeNotFound inputForeignGlob
foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)
case runWriterT (parseInputs moduleFiles foreignFiles) of
Left errs -> do
@@ -78,13 +78,25 @@ compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = d
hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
exitSuccess
+warnFileTypeNotFound :: String -> IO ()
+warnFileTypeNotFound = hPutStrLn stderr . ((++) "psc: No files found using pattern: ")
+
+globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
+globWarningOnMisses warn = concatMapM globWithWarning
+ where
+ globWithWarning pattern = do
+ paths <- glob pattern
+ when (null paths) $ warn pattern
+ return paths
+ concatMapM f = liftM concat . mapM f
+
readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
=> [(Either P.RebuildPolicy FilePath, String)]
-> [(FilePath, P.ForeignJS)]
- -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName (FilePath, P.ForeignJS))
+ -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName FilePath)
parseInputs modules foreigns =
(,) <$> P.parseModulesFromFiles (either (const "") id) modules
<*> P.parseForeignModulesFromFiles foreigns
diff --git a/psci/PSCi.hs b/psci/PSCi.hs
index e839ac3..5d52c22 100644
--- a/psci/PSCi.hs
+++ b/psci/PSCi.hs
@@ -251,7 +251,7 @@ modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
-- options and ignores the warning messages.
runMake :: P.Make a -> IO (Either P.MultipleErrors a)
-runMake mk = fmap (fmap fst) $ P.runMake (P.Options False False Nothing False False False Nothing) mk
+runMake mk = fmap (fmap fst) $ P.runMake P.defaultOptions mk
makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a
makeIO f io = do
diff --git a/psci/Types.hs b/psci/Types.hs
index b7684ab..107a353 100644
--- a/psci/Types.hs
+++ b/psci/Types.hs
@@ -35,7 +35,7 @@ data PSCiState = PSCiState
{ psciImportedFilenames :: [FilePath]
, psciImportedModules :: [ImportedModule]
, psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
- , psciForeignFiles :: M.Map P.ModuleName (FilePath, P.ForeignJS)
+ , psciForeignFiles :: M.Map P.ModuleName FilePath
, psciLetBindings :: [P.Declaration]
, psciNodeFlags :: [String]
}
@@ -91,7 +91,7 @@ updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
-- |
-- Updates the state to have more let bindings.
--
-updateForeignFiles :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> PSCiState -> PSCiState
+updateForeignFiles :: M.Map P.ModuleName FilePath -> PSCiState -> PSCiState
updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `M.union` fs }
-- |
diff --git a/psci/tests/data/Sample.purs b/psci/tests/data/Sample.purs
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/psci/tests/data/Sample.purs
diff --git a/purescript.cabal b/purescript.cabal
index 4fcefde..0140e8e 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.7.2.1
+version: 0.7.3.0
cabal-version: >=1.8
build-type: Simple
license: MIT
@@ -20,8 +20,10 @@ tested-with: GHC==7.8
extra-source-files: examples/passing/*.purs
, examples/failing/*.purs
- , tests/support/flattened/*.purs
- , tests/support/flattened/*.js
+ , tests/support/setup.js
+ , tests/support/package.json
+ , tests/support/bower.json
+ , psci/tests/data/Sample.purs
source-repository head
type: git
@@ -120,6 +122,7 @@ library
Language.PureScript.Sugar.ObjectWildcards
Language.PureScript.Sugar.Operators
Language.PureScript.Sugar.TypeClasses
+ Language.PureScript.Sugar.TypeClasses.Deriving
Language.PureScript.Sugar.TypeDeclarations
Language.PureScript.Traversals
Language.PureScript.TypeChecker
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index d52c5d0..490bc61 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -19,6 +19,10 @@ module Language.PureScript.AST.Declarations where
import qualified Data.Data as D
import qualified Data.Map as M
+import Control.Monad.Identity
+
+import Control.Applicative
+
import Language.PureScript.AST.Binders
import Language.PureScript.AST.Operators
import Language.PureScript.AST.SourcePos
@@ -154,13 +158,29 @@ data Declaration
-- A type instance declaration (name, dependencies, class name, instance types, member
-- declarations)
--
- | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]
+ | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] TypeInstanceBody
-- |
-- A declaration with source position information
--
| PositionedDeclaration SourceSpan [Comment] Declaration
deriving (Show, D.Data, D.Typeable)
+-- | The members of a type class instance declaration
+data TypeInstanceBody
+ -- | This is a derived instance
+ = DerivedInstance
+ -- | This is a regular (explicit) instance
+ | ExplicitInstance [Declaration]
+ deriving (Show, D.Data, D.Typeable)
+
+mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
+mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
+
+-- | A traversal for TypeInstanceBody
+traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
+traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance
+traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds
+
-- |
-- Test if a declaration is a value declaration
--
diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs
index 652369d..0a33f2a 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -16,6 +16,7 @@ module Language.PureScript.AST.Traversals where
import Data.Monoid (Monoid(..), mconcat)
import Data.Maybe (mapMaybe)
+import Data.Traversable (traverse)
import Control.Applicative
import Control.Monad
@@ -37,7 +38,7 @@ everywhereOnValues f g h = (f', g', h')
f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
- f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))
+ f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds))
f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))
f' other = f other
@@ -95,7 +96,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds
- f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds
+ f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds
f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
f' other = f other
@@ -147,7 +148,7 @@ everywhereOnValuesM f g h = (f', g', h')
f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f
f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f
- f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f
+ f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM f') ds) >>= f
f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
f' other = f other
@@ -202,7 +203,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)
- f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
+ f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds)
f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
f' d = f d
@@ -266,7 +267,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
- f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
+ f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds)
f' s (PositionedDeclaration _ _ d1) = f'' s d1
f' _ _ = r0
@@ -335,7 +336,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds
f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds
- f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds
+ f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (mapM (f'' s)) ds
f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1
f' _ other = return other
diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs
index 10d627e..2449468 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -238,6 +238,20 @@ semigroupString = "semigroupString"
semigroupoidArr :: String
semigroupoidArr = "semigroupoidArr"
+-- Generic Deriving
+
+generic :: String
+generic = "Generic"
+
+toSpine :: String
+toSpine = "toSpine"
+
+fromSpine :: String
+fromSpine = "fromSpine"
+
+toSignature :: String
+toSignature = "toSignature"
+
-- Main module
main :: String
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 88f8b7e..8d403f9 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.Error
--- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -102,6 +102,8 @@ data SimpleErrorMessage
| ConstrainedTypeUnified Type Type
| OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]
| NoInstanceFound (Qualified ProperName) [Type]
+ | CannotDerive (Qualified ProperName) [Type]
+ | CannotFindDerivingType ProperName
| DuplicateLabel String (Maybe Expr)
| DuplicateValueDeclaration Ident
| ArgListLengthsDiffer Ident
@@ -115,6 +117,7 @@ data SimpleErrorMessage
| PropertyIsMissing String Type
| CannotApplyFunction Type Expr
| TypeSynonymInstance
+ | OrphanInstance Ident (Qualified ProperName) [Type]
| InvalidNewtype
| InvalidInstanceHead Type
| TransitiveExportError DeclarationRef [DeclarationRef]
@@ -213,6 +216,8 @@ errorCode em = case unwrapErrorMessage em of
(ConstrainedTypeUnified _ _) -> "ConstrainedTypeUnified"
(OverlappingInstances _ _ _) -> "OverlappingInstances"
(NoInstanceFound _ _) -> "NoInstanceFound"
+ (CannotDerive _ _) -> "CannotDerive"
+ (CannotFindDerivingType _) -> "CannotFindDerivingType"
(DuplicateLabel _ _) -> "DuplicateLabel"
(DuplicateValueDeclaration _) -> "DuplicateValueDeclaration"
(ArgListLengthsDiffer _) -> "ArgListLengthsDiffer"
@@ -226,6 +231,7 @@ errorCode em = case unwrapErrorMessage em of
(PropertyIsMissing _ _) -> "PropertyIsMissing"
(CannotApplyFunction _ _) -> "CannotApplyFunction"
TypeSynonymInstance -> "TypeSynonymInstance"
+ (OrphanInstance _ _ _) -> "OrphanInstance"
InvalidNewtype -> "InvalidNewtype"
(InvalidInstanceHead _) -> "InvalidInstanceHead"
(TransitiveExportError _ _) -> "TransitiveExportError"
@@ -242,10 +248,10 @@ newtype MultipleErrors = MultipleErrors
{ runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)
instance UnificationError Type MultipleErrors where
- occursCheckFailed = occursCheckFailed
+ occursCheckFailed t = MultipleErrors [occursCheckFailed t]
instance UnificationError Kind MultipleErrors where
- occursCheckFailed = occursCheckFailed
+ occursCheckFailed k = MultipleErrors [occursCheckFailed k]
-- | Check whether a collection of errors is empty or not.
nonEmpty :: MultipleErrors -> Bool
@@ -507,6 +513,10 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
]
goSimple (NoInstanceFound nm ts) =
line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
+ goSimple (CannotDerive nm ts) =
+ line $ "Cannot derive " ++ show nm ++ " instance for " ++ unwords (map prettyPrintTypeAtom ts)
+ goSimple (CannotFindDerivingType nm) =
+ line $ "Cannot derive instance, because the type declaration for " ++ show nm ++ " could not be found."
goSimple (DuplicateLabel l expr) =
paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
<> foldMap (\expr' -> [ line "Relevant expression: "
@@ -545,6 +555,8 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
]
goSimple TypeSynonymInstance =
line "Type synonym instances are disallowed"
+ goSimple (OrphanInstance nm cnm ts) =
+ line $ "Instance " ++ show nm ++ " for " ++ show cnm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ " is an orphan instance"
goSimple InvalidNewtype =
line "Newtypes must define a single constructor with a single argument"
goSimple (InvalidInstanceHead ty) =
@@ -747,24 +759,32 @@ prettyPrintSingleError full level e = prettyPrintErrorMessage <$> onTypesInError
-- Pretty print multiple errors
--
prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
-prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full
+prettyPrintMultipleErrors full = renderBox . prettyPrintMultipleErrorsBox full
-- |
-- Pretty print multiple warnings
--
prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
-prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Multiple warnings found:" full
+prettyPrintMultipleWarnings full = renderBox . prettyPrintMultipleWarningsBox full
-prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap String
+-- | Pretty print warnings as a Box
+prettyPrintMultipleWarningsBox :: Bool -> MultipleErrors -> Box.Box
+prettyPrintMultipleWarningsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Warning "Warning found:" "Multiple warnings found:" full
+
+-- | Pretty print errors as a Box
+prettyPrintMultipleErrorsBox :: Bool -> MultipleErrors -> Box.Box
+prettyPrintMultipleErrorsBox full = flip evalState M.empty . prettyPrintMultipleErrorsWith Error "Error found:" "Multiple errors found:" full
+
+prettyPrintMultipleErrorsWith :: Level -> String -> String -> Bool -> MultipleErrors -> State UnknownMap Box.Box
prettyPrintMultipleErrorsWith level intro _ full (MultipleErrors [e]) = do
result <- prettyPrintSingleError full level e
- return $ renderBox $
+ return $
Box.vcat Box.left [ Box.text intro
, result
]
prettyPrintMultipleErrorsWith level _ intro full (MultipleErrors es) = do
result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full level
- return $ renderBox $
+ return $
Box.vcat Box.left [ Box.text intro
, Box.vsep 1 Box.left result
]
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 6ed68bc..eae2bd1 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -24,8 +24,8 @@ module Language.PureScript.Make
(
-- * Make API
RebuildPolicy(..)
+ , ProgressMessage(..), renderProgressMessage
, MakeActions(..)
- , SupplyVar()
, Externs()
, make
@@ -43,12 +43,12 @@ import Control.Monad.Trans.Except
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Supply
-import Control.Monad.Supply.Class (fresh)
import Data.Function (on)
import Data.List (sortBy, groupBy)
import Data.Maybe (fromMaybe)
import Data.Time.Clock
+import Data.Foldable (for_)
import Data.Traversable (traverse)
import Data.Version (showVersion)
import qualified Data.Map as M
@@ -59,7 +59,6 @@ import System.Directory
import System.FilePath ((</>), takeDirectory)
import System.IO.Error (tryIOError)
-
import Language.PureScript.AST
import Language.PureScript.CodeGen.Externs (moduleToPs)
import Language.PureScript.Environment
@@ -79,8 +78,22 @@ import qualified Language.PureScript.CodeGen.JS as J
import qualified Language.PureScript.CoreFn as CF
import qualified Paths_purescript as Paths
--- |
--- Actions that require implementations when running in "make" mode.
+-- | Progress messages from the make process
+data ProgressMessage
+ = CompilingModule ModuleName
+ deriving (Show, Eq, Ord)
+
+-- | Render a progress message
+renderProgressMessage :: ProgressMessage -> String
+renderProgressMessage (CompilingModule mn) = "Compiling " ++ runModuleName mn
+
+-- | Actions that require implementations when running in "make" mode.
+--
+-- This type exists to make two things abstract:
+--
+-- * The particular backend being used (Javascript, C++11, etc.)
+--
+-- * The details of how files are read/written etc.
--
data MakeActions m = MakeActions {
-- |
@@ -102,11 +115,11 @@ data MakeActions m = MakeActions {
-- |
-- Run the code generator for the module and write any required output files.
--
- , codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> m ()
+ , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
-- |
-- Respond to a progress update.
--
- , progress :: String -> m ()
+ , progress :: ProgressMessage -> m ()
}
-- |
@@ -115,11 +128,6 @@ data MakeActions m = MakeActions {
type Externs = String
-- |
--- A value to be used in the Supply monad.
---
-type SupplyVar = Integer
-
--- |
-- Determines when to rebuild a module
--
data RebuildPolicy
@@ -140,7 +148,6 @@ make :: forall m. (Functor m, Applicative m, Monad m, MonadReader Options m, Mon
-> m Environment
make MakeActions{..} ms = do
(sorted, graph) <- sortModules $ map importPrim ms
- mapM_ lint sorted
toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
inputTimestamp <- getInputTimestamp moduleName'
outputTimestamp <- getOutputTimestamp moduleName'
@@ -150,6 +157,7 @@ make MakeActions{..} ms = do
_ -> S.insert moduleName' s) S.empty sorted
marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
+ for_ marked $ \(willRebuild, m) -> when willRebuild (lint m)
(desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
evalSupplyT nextVar $ go initEnvironment desugared
where
@@ -160,7 +168,7 @@ make MakeActions{..} ms = do
(_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
go env' ms'
go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
- lift $ progress $ "Compiling " ++ runModuleName moduleName'
+ lift . progress $ CompilingModule moduleName'
(checked@(Module _ _ elaborated _), env') <- lift . runCheck' env $ typeCheckModule Nothing m
checkExhaustiveModule env' checked
regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
@@ -168,8 +176,7 @@ make MakeActions{..} ms = do
corefn = CF.moduleToCoreFn env' mod'
[renamed] = renameInModules [corefn]
exts = moduleToPs mod' env'
- nextVar <- fresh
- lift $ codegen renamed env' nextVar exts
+ codegen renamed env' exts
go env' ms'
rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
@@ -237,8 +244,8 @@ traverseEither f (Right y) = Right <$> f y
-- A set of make actions that read and write modules from the given directory.
--
buildMakeActions :: FilePath -- ^ the output directory
- -> M.Map ModuleName (Either RebuildPolicy String) -- ^ a map between module names and paths to the file containing the PureScript module
- -> M.Map ModuleName (FilePath, ForeignJS) -- ^ a map between module name and the file containing the foreign javascript for the module
+ -> M.Map ModuleName (Either RebuildPolicy FilePath) -- ^ a map between module names and paths to the file containing the PureScript module
+ -> M.Map ModuleName FilePath -- ^ a map between module name and the file containing the foreign javascript for the module
-> Bool -- ^ Generate a prefix comment?
-> MakeActions Make
buildMakeActions outputDir filePathMap foreigns usePrefix =
@@ -249,7 +256,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
getInputTimestamp mn = do
let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
e1 <- traverseEither getTimestamp path
- fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
+ fPath <- maybe (return Nothing) getTimestamp $ M.lookup mn foreigns
return $ fmap (max fPath) e1
getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
@@ -264,29 +271,28 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
let path = outputDir </> runModuleName mn </> "externs.purs"
(path, ) <$> readTextFile path
- codegen :: CF.Module CF.Ann -> Environment -> SupplyVar -> Externs -> Make ()
- codegen m _ nextVar exts = do
+ codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
+ codegen m _ exts = do
let mn = CF.moduleName m
foreignInclude <- case mn `M.lookup` foreigns of
- Just (path, _)
+ Just path
| not $ requiresForeign m -> do
tell $ errorMessage $ UnnecessaryFFIModule mn path
return Nothing
| otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
Nothing | requiresForeign m -> throwError . errorMessage $ MissingFFIModule mn
| otherwise -> return Nothing
- pjs <- evalSupplyT nextVar $ prettyPrintJS <$> J.moduleToJs m foreignInclude
+ pjs <- prettyPrintJS <$> J.moduleToJs m foreignInclude
let filePath = runModuleName mn
jsFile = outputDir </> filePath </> "index.js"
externsFile = outputDir </> filePath </> "externs.purs"
foreignFile = outputDir </> filePath </> "foreign.js"
prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
js = unlines $ map ("// " ++) prefix ++ [pjs]
- verboseErrorsEnabled <- asks optionsVerboseErrors
- when verboseErrorsEnabled $ progress $ "Writing " ++ jsFile
- writeTextFile jsFile js
- maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
- writeTextFile externsFile exts
+ lift $ do
+ writeTextFile jsFile js
+ for_ (mn `M.lookup` foreigns) (readTextFile >=> writeTextFile foreignFile)
+ writeTextFile externsFile exts
requiresForeign :: CF.Module a -> Bool
requiresForeign = not . null . CF.moduleForeign
@@ -307,5 +313,5 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
mkdirp :: FilePath -> IO ()
mkdirp = createDirectoryIfMissing True . takeDirectory
- progress :: String -> Make ()
- progress = liftIO . putStrLn
+ progress :: ProgressMessage -> Make ()
+ progress = liftIO . putStrLn . renderProgressMessage
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 0786ddf..475a9b0 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -229,7 +229,21 @@ parseTypeInstanceDeclaration = do
members <- P.option [] . P.try $ do
indented *> reserved "where"
mark (P.many (same *> positioned parseValueDeclaration))
- return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty (ExplicitInstance members)
+
+parseDerivingInstanceDeclaration :: TokenParser Declaration
+parseDerivingInstanceDeclaration = do
+ reserved "derive"
+ reserved "instance"
+ name <- parseIdent <* indented <* doubleColon
+ deps <- P.optionMaybe $ do
+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
+ indented
+ rfatArrow
+ return deps
+ className <- indented *> parseQualified properName
+ ty <- P.many (indented *> noWildcards parseTypeAtom)
+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty DerivedInstance
positioned :: TokenParser Declaration -> TokenParser Declaration
positioned = withSourceSpan PositionedDeclaration
@@ -248,6 +262,7 @@ parseDeclaration = positioned (P.choice
, parseImportDeclaration
, parseTypeClassDeclaration
, parseTypeInstanceDeclaration
+ , parseDerivingInstanceDeclaration
]) P.<?> "declaration"
parseLocalDeclaration :: TokenParser Declaration
diff --git a/src/Language/PureScript/Parser/JS.hs b/src/Language/PureScript/Parser/JS.hs
index 63ead36..d6466e7 100644
--- a/src/Language/PureScript/Parser/JS.hs
+++ b/src/Language/PureScript/Parser/JS.hs
@@ -37,17 +37,17 @@ type ForeignJS = String
parseForeignModulesFromFiles :: (Functor m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> [(FilePath, ForeignJS)]
- -> m (M.Map ModuleName (FilePath, ForeignJS))
+ -> m (M.Map ModuleName FilePath)
parseForeignModulesFromFiles files = do
foreigns <- parU files $ \(path, file) ->
case findModuleName (lines file) of
- Just name -> return (name, (path, file))
+ Just name -> return (name, path)
Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path)
let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns
forM_ grouped $ \grp ->
when (length grp > 1) $ do
let mn = fst (head grp)
- paths = map (fst . snd) grp
+ paths = map snd grp
tell $ errorMessage $ MultipleFFIModules mn paths
return $ M.fromList foreigns
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
index db084f6..449c055 100644
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ b/src/Language/PureScript/Parser/Lexer.hs
@@ -494,6 +494,7 @@ reservedPsNames = [ "data"
, "infix"
, "class"
, "instance"
+ , "derive"
, "module"
, "case"
, "of"
diff --git a/src/Language/PureScript/Pretty/JS.hs b/src/Language/PureScript/Pretty/JS.hs
index 4223305..ae0060a 100644
--- a/src/Language/PureScript/Pretty/JS.hs
+++ b/src/Language/PureScript/Pretty/JS.hs
@@ -163,6 +163,7 @@ string s = '"' : concatMap encodeChar s ++ "\""
encodeChar '\\' = "\\\\"
encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""
encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""
+ encodeChar c | fromEnum c > 0x7E || fromEnum c < 0x20 = "\\x" ++ showHex (fromEnum c) ""
encodeChar c = [c]
conditional :: Pattern PrinterState JS ((JS, JS), JS)
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
index 256638f..b1704d3 100644
--- a/src/Language/PureScript/Publish/ErrorsWarnings.hs
+++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -198,12 +198,12 @@ displayUserError e = case e of
ParseAndDesugarError (D.SortModulesError err) ->
vcat
[ para "Error in sortModules:"
- , indented (para (P.prettyPrintMultipleErrors False err))
+ , indented (P.prettyPrintMultipleErrorsBox False err)
]
ParseAndDesugarError (D.DesugarError err) ->
vcat
[ para "Error while desugaring:"
- , indented (para (P.prettyPrintMultipleErrors False err))
+ , indented (P.prettyPrintMultipleErrorsBox False err)
]
DirtyWorkingTree ->
para (concat
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index ac89f5c..9c9f875 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -33,6 +33,7 @@ import Language.PureScript.Sugar.Names as S
import Language.PureScript.Sugar.ObjectWildcards as S
import Language.PureScript.Sugar.Operators as S
import Language.PureScript.Sugar.TypeClasses as S
+import Language.PureScript.Sugar.TypeClasses.Deriving as S
import Language.PureScript.Sugar.TypeDeclarations as S
-- |
@@ -67,5 +68,6 @@ desugar = map removeSignedLiterals
>=> desugarTypeDeclarationsModule
>=> desugarImports
>=> rebracket
+ >=> mapM deriveInstances
>=> desugarTypeClasses
>=> createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 93cb68c..74485ac 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -68,7 +68,7 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGro
where
desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
- (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
+ (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest
desugarRest (ValueDeclaration name nameKind bs result : rest) =
let (_, f, _) = everywhereOnValuesTopDownM return go return
f' (Left gs) = Left <$> mapM (pairM return f) gs
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 83bf381..541c152 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -166,7 +166,8 @@ desugarDecl mn exps = go
modify (M.insert (mn, name) d)
return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
- go d@(TypeInstanceDeclaration name deps className tys members) = do
+ go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = error "Derived instanced should have been desugared"
+ go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do
desugared <- desugarCases members
dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
return (expRef name className tys, [d, dictDecl])
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
new file mode 100644
index 0000000..2e4a306
--- /dev/null
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -0,0 +1,229 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.Sugar.TypeClasses.Deriving
+-- Copyright : (c) Gershom Bazerman 2015
+-- License : MIT (http://opensource.org/licenses/MIT)
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+-- This module implements the generic deriving elaboration that takes place during desugaring.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Language.PureScript.Sugar.TypeClasses.Deriving (
+ deriveInstances
+) where
+
+import Data.List
+import Data.Maybe (fromMaybe)
+import Data.Ord (comparing)
+
+import Control.Applicative
+import Control.Monad (replicateM)
+import Control.Monad.Supply.Class (MonadSupply, freshName)
+import Control.Monad.Error.Class (MonadError(..))
+
+import Language.PureScript.AST
+import Language.PureScript.Environment
+import Language.PureScript.Errors
+import Language.PureScript.Names
+import Language.PureScript.Types
+import qualified Language.PureScript.Constants as C
+
+-- | Elaborates deriving instance declarations by code generation.
+deriveInstances :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadSupply m) => Module -> m Module
+deriveInstances (Module coms mn ds exts) = Module coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts
+
+-- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration,
+-- elaborates that into an instance declaration via code generation.
+deriveInstance :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> Declaration -> m Declaration
+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance)
+ | className == Qualified (Just dataGeneric) (ProperName C.generic)
+ , Just (Qualified mn' tyCon) <- unwrapTypeConstructor ty
+ , mn == fromMaybe mn mn'
+ = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon
+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
+ = throwError . errorMessage $ CannotDerive className tys
+deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d
+deriveInstance _ _ e = return e
+
+unwrapTypeConstructor :: Type -> Maybe (Qualified ProperName)
+unwrapTypeConstructor (TypeConstructor tyCon) = Just tyCon
+unwrapTypeConstructor (TypeApp ty (TypeVar _)) = unwrapTypeConstructor ty
+unwrapTypeConstructor _ = Nothing
+
+dataGeneric :: ModuleName
+dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
+
+dataMaybe :: ModuleName
+dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
+
+deriveGeneric :: (Functor m, MonadError MultipleErrors m, MonadSupply m) => ModuleName -> [Declaration] -> ProperName -> m [Declaration]
+deriveGeneric mn ds tyConNm = do
+ tyCon <- findTypeDecl tyConNm ds
+ toSpine <- mkSpineFunction mn tyCon
+ fromSpine <- mkFromSpineFunction mn tyCon
+ let toSignature = mkSignatureFunction mn tyCon
+ return [ ValueDeclaration (Ident C.toSpine) Public [] (Right toSpine)
+ , ValueDeclaration (Ident C.fromSpine) Public [] (Right fromSpine)
+ , ValueDeclaration (Ident C.toSignature) Public [] (Right toSignature)
+ ]
+
+findTypeDecl :: (Functor m, MonadError MultipleErrors m) => ProperName -> [Declaration] -> m Declaration
+findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl
+ where
+ isTypeDecl :: Declaration -> Bool
+ isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True
+ isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d
+ isTypeDecl _ = False
+
+mkSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
+mkSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> mapM mkCtorClause args
+ where
+ prodConstructor :: Expr -> Expr
+ prodConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SProd")))
+
+ recordConstructor :: Expr -> Expr
+ recordConstructor = App (Constructor (Qualified (Just dataGeneric) (ProperName "SRecord")))
+
+ mkCtorClause :: (ProperName, [Type]) -> m CaseAlternative
+ mkCtorClause (ctorName, tys) = do
+ idents <- replicateM (length tys) (fmap Ident freshName)
+ return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents))
+ where
+ caseResult idents =
+ App (prodConstructor (StringLiteral . runProperName $ ctorName))
+ . ArrayLiteral
+ $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys
+
+ toSpineFun :: Expr -> Type -> Expr
+ toSpineFun i r | Just rec <- objectType r =
+ lamNull . recordConstructor . ArrayLiteral .
+ map (\(str,typ) -> ObjectLiteral [("recLabel", StringLiteral str), ("recValue", toSpineFun (Accessor str i) typ)])
+ $ decomposeRec rec
+ toSpineFun i _ = lamNull $ App (mkGenVar C.toSpine) i
+mkSpineFunction mn (PositionedDeclaration _ _ d) = mkSpineFunction mn d
+mkSpineFunction _ _ = error "mkSpineFunction: expected DataDeclaration"
+
+mkSignatureFunction :: ModuleName -> Declaration -> Expr
+mkSignatureFunction _ (DataDeclaration _ _ _ args) = lamNull . mkSigProd $ map mkProdClause args
+ where
+ mkSigProd :: [Expr] -> Expr
+ mkSigProd = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigProd"))) . ArrayLiteral
+
+ mkSigRec :: [Expr] -> Expr
+ mkSigRec = App (Constructor (Qualified (Just dataGeneric) (ProperName "SigRecord"))) . ArrayLiteral
+
+ proxy :: Type -> Type
+ proxy = TypeApp (TypeConstructor (Qualified (Just dataGeneric) (ProperName "Proxy")))
+
+ mkProdClause :: (ProperName, [Type]) -> Expr
+ mkProdClause (ctorName, tys) = ObjectLiteral [ ("sigConstructor", StringLiteral (runProperName ctorName))
+ , ("sigValues", ArrayLiteral . map mkProductSignature $ tys)
+ ]
+
+ mkProductSignature :: Type -> Expr
+ mkProductSignature r | Just rec <- objectType r =
+ lamNull . mkSigRec $ [ ObjectLiteral [ ("recLabel", StringLiteral str)
+ , ("recValue", mkProductSignature typ)
+ ]
+ | (str, typ) <- decomposeRec rec
+ ]
+ mkProductSignature typ = lamNull $ App (mkGenVar C.toSignature)
+ (TypedValue False (mkGenVar "anyProxy") (proxy typ))
+mkSignatureFunction mn (PositionedDeclaration _ _ d) = mkSignatureFunction mn d
+mkSignatureFunction _ _ = error "mkSignatureFunction: expected DataDeclaration"
+
+mkFromSpineFunction :: forall m. (Functor m, MonadSupply m) => ModuleName -> Declaration -> m Expr
+mkFromSpineFunction mn (DataDeclaration _ _ _ args) = lamCase "$x" <$> (addCatch <$> mapM mkAlternative args)
+ where
+ mkJust :: Expr -> Expr
+ mkJust = App (Constructor (Qualified (Just dataMaybe) (ProperName "Just")))
+
+ mkNothing :: Expr
+ mkNothing = Constructor (Qualified (Just dataMaybe) (ProperName "Nothing"))
+
+ prodBinder :: [Binder] -> Binder
+ prodBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SProd"))
+
+ recordBinder :: [Binder] -> Binder
+ recordBinder = ConstructorBinder (Qualified (Just dataGeneric) (ProperName "SRecord"))
+
+ mkAlternative :: (ProperName, [Type]) -> m CaseAlternative
+ mkAlternative (ctorName, tys) = do
+ idents <- replicateM (length tys) (fmap Ident freshName)
+ return $ CaseAlternative [ prodBinder [ StringBinder (runProperName ctorName), ArrayBinder (map VarBinder idents)]]
+ . Right
+ $ liftApplicative (mkJust $ Constructor (Qualified (Just mn) ctorName))
+ (zipWith fromSpineFun (map (Var . (Qualified Nothing)) idents) tys)
+
+ addCatch :: [CaseAlternative] -> [CaseAlternative]
+ addCatch = (++ [catchAll])
+ where
+ catchAll = CaseAlternative [NullBinder] (Right mkNothing)
+
+ fromSpineFun e r
+ | Just rec <- objectType r
+ = App (lamCase "r" [ mkRecCase (decomposeRec rec)
+ , CaseAlternative [NullBinder] (Right mkNothing)
+ ])
+ (App e (mkPrelVar "unit"))
+
+ fromSpineFun e _ = App (mkGenVar C.fromSpine) (App e (mkPrelVar "unit"))
+
+ mkRecCase rs = CaseAlternative [ recordBinder [ ArrayBinder (map (VarBinder . Ident . fst) rs)
+ ]
+ ]
+ . Right
+ $ liftApplicative (mkRecFun rs) (map (\(x, y) -> fromSpineFun (Accessor "recValue" (mkVar x)) y) rs)
+
+ mkRecFun :: [(String, Type)] -> Expr
+ mkRecFun xs = mkJust $ foldr (\s e -> lam s e) recLiteral (map fst xs)
+ where recLiteral = ObjectLiteral $ map (\(s,_) -> (s,mkVar s)) xs
+mkFromSpineFunction mn (PositionedDeclaration _ _ d) = mkFromSpineFunction mn d
+mkFromSpineFunction _ _ = error "mkFromSpineFunction: expected DataDeclaration"
+
+-- Helpers
+
+objectType :: Type -> Maybe Type
+objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Object"))) rec) = Just rec
+objectType _ = Nothing
+
+lam :: String -> Expr -> Expr
+lam s = Abs (Left (Ident s))
+
+lamNull :: Expr -> Expr
+lamNull = lam "$q"
+
+lamCase :: String -> [CaseAlternative] -> Expr
+lamCase s = lam s . Case [mkVar s]
+
+liftApplicative :: Expr -> [Expr] -> Expr
+liftApplicative = foldl' (\x e -> App (App (mkPrelVar "apply") x) e)
+
+mkVarMn :: Maybe ModuleName -> String -> Expr
+mkVarMn mn s = Var (Qualified mn (Ident s))
+
+mkVar :: String -> Expr
+mkVar s = mkVarMn Nothing s
+
+mkPrelVar :: String -> Expr
+mkPrelVar s = mkVarMn (Just (ModuleName [ProperName C.prelude])) s
+
+mkGenVar :: String -> Expr
+mkGenVar s = mkVarMn (Just (ModuleName [ProperName "Data", ProperName C.generic])) s
+
+decomposeRec :: Type -> [(String, Type)]
+decomposeRec = sortBy (comparing fst) . go
+ where go (RCons str typ typs) = (str, typ) : decomposeRec typs
+ go _ = [] \ No newline at end of file
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index a510dd4..5a7a253 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -1,8 +1,8 @@
-----------------------------------------------------------------------------
--
-- Module : Language.PureScript.TypeChecker
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
+-- Copyright : (c) 2013-15 Phil Freeman, (c) 2014-15 Gary Burgess
+-- License : MIT (http://opensource.org/licenses/MIT)
--
-- Maintainer : Phil Freeman <paf31@cantab.net>
-- Stability : experimental
@@ -235,12 +235,26 @@ typeCheckAll mainModuleName moduleName exps ds = mapM go ds <* mapM_ checkOrphan
goInstance d dictName deps className tys = do
mapM_ (checkTypeClassInstance moduleName) tys
forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
+ checkOrphanInstance moduleName className tys
let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported
addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (canonicalizeDictionary dict) dict
return d
where
+ checkOrphanInstance :: ModuleName -> Qualified ProperName -> [Type] -> Check ()
+ checkOrphanInstance mn (Qualified (Just mn') _) tys
+ | mn == mn' || any checkType tys = return ()
+ | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys
+ where
+ checkType :: Type -> Bool
+ checkType (TypeVar _) = False
+ checkType (TypeConstructor (Qualified (Just mn'') _)) = mn == mn''
+ checkType (TypeConstructor (Qualified Nothing _)) = error "Unqualified type name in checkOrphanInstance"
+ checkType (TypeApp t1 _) = checkType t1
+ checkType _ = error "Invalid type in instance in checkOrphanInstance"
+ checkOrphanInstance _ _ _ = error "Unqualified class name in checkOrphanInstance"
+
isInstanceExported :: Bool
isInstanceExported = any exportsInstance exps
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 0f65a58..87866a8 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -578,6 +578,7 @@ containsTypeSynonyms = everythingOnTypes (||) go where
go (SaturatedTypeSynonym _ _) = True
go _ = False
+
-- |
-- Check the type of a collection of named record fields
--
diff --git a/tests/Main.hs b/tests/Main.hs
index 398649c..acb9aa6 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -69,61 +69,25 @@ import Text.Parsec (ParseError)
modulesDir :: FilePath
modulesDir = ".test_modules" </> "node_modules"
-newtype Test a = Test { unTest :: ReaderT P.Options (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
- deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader P.Options)
-
-runTest :: Test a -> IO (Either P.MultipleErrors a)
-runTest = runExceptT . fmap fst . runWriterT . flip runReaderT P.defaultOptions . unTest
-
-makeActions :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> P.MakeActions Test
-makeActions foreigns = P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
+makeActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
+makeActions foreigns = (P.buildMakeActions modulesDir (error "makeActions: input file map was read.") foreigns False)
+ { P.getInputTimestamp = getInputTimestamp
+ , P.getOutputTimestamp = getOutputTimestamp
+ }
where
- getInputTimestamp :: P.ModuleName -> Test (Either P.RebuildPolicy (Maybe UTCTime))
+ getInputTimestamp :: P.ModuleName -> P.Make (Either P.RebuildPolicy (Maybe UTCTime))
getInputTimestamp mn
| isSupportModule (P.runModuleName mn) = return (Left P.RebuildNever)
| otherwise = return (Left P.RebuildAlways)
where
isSupportModule = flip elem supportModules
- getOutputTimestamp :: P.ModuleName -> Test (Maybe UTCTime)
+ getOutputTimestamp :: P.ModuleName -> P.Make (Maybe UTCTime)
getOutputTimestamp mn = do
let filePath = modulesDir </> P.runModuleName mn
exists <- liftIO $ doesDirectoryExist filePath
return (if exists then Just (error "getOutputTimestamp: read timestamp") else Nothing)
- readExterns :: P.ModuleName -> Test (FilePath, String)
- readExterns mn = do
- let filePath = modulesDir </> P.runModuleName mn </> "externs.purs"
- (filePath, ) <$> readTextFile filePath
-
- codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Test ()
- codegen m _ nextVar exts = do
- let mn = CF.moduleName m
- foreignInclude <- case (CF.moduleName m `M.lookup` foreigns, CF.moduleForeign m) of
- (Just _, []) -> error "Unnecessary foreign module"
- (Just path, _) -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
- (Nothing, []) -> return Nothing
- (Nothing, _) -> error "Missing foreign module"
- pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
- let filePath = P.runModuleName $ CF.moduleName m
- jsFile = modulesDir </> filePath </> "index.js"
- externsFile = modulesDir </> filePath </> "externs.purs"
- foreignFile = modulesDir </> filePath </> "foreign.js"
- writeTextFile jsFile pjs
- maybe (return ()) (writeTextFile foreignFile . snd) $ CF.moduleName m `M.lookup` foreigns
- writeTextFile externsFile exts
-
- readTextFile :: FilePath -> Test String
- readTextFile path = liftIO $ readFile path
-
- writeTextFile :: FilePath -> String -> Test ()
- writeTextFile path text = liftIO $ do
- createDirectoryIfMissing True (takeDirectory path)
- writeFile path text
-
- progress :: String -> Test ()
- progress = liftIO . putStrLn
-
readInput :: [FilePath] -> IO [(FilePath, String)]
readInput inputFiles = forM inputFiles $ \inputFile -> do
text <- readFile inputFile
@@ -131,14 +95,17 @@ readInput inputFiles = forM inputFiles $ \inputFile -> do
type TestM = WriterT [(FilePath, String)] IO
-compile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> IO (Either P.MultipleErrors P.Environment)
+runTest :: P.Make a -> IO (Either P.MultipleErrors a)
+runTest = fmap (fmap fst) . P.runMake P.defaultOptions
+
+compile :: [FilePath] -> M.Map P.ModuleName FilePath -> IO (Either P.MultipleErrors P.Environment)
compile inputFiles foreigns = runTest $ do
fs <- liftIO $ readInput inputFiles
ms <- P.parseModulesFromFiles id fs
P.make (makeActions foreigns) (map snd ms)
assert :: [FilePath] ->
- M.Map P.ModuleName (FilePath, P.ForeignJS) ->
+ M.Map P.ModuleName FilePath ->
(Either P.MultipleErrors P.Environment -> IO (Maybe String)) ->
TestM ()
assert inputFiles foreigns f = do
@@ -148,7 +115,7 @@ assert inputFiles foreigns f = do
Just err -> tell [(last inputFiles, err)]
Nothing -> return ()
-assertCompiles :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM ()
+assertCompiles :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
assertCompiles inputFiles foreigns = do
liftIO . putStrLn $ "Assert " ++ last inputFiles ++ " compiles successfully"
assert inputFiles foreigns $ \e ->
@@ -164,7 +131,7 @@ assertCompiles inputFiles foreigns = do
Just (ExitFailure _, _, err) -> return $ Just err
Nothing -> return $ Just "Couldn't find node.js executable"
-assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> TestM ()
+assertDoesNotCompile :: [FilePath] -> M.Map P.ModuleName FilePath -> TestM ()
assertDoesNotCompile inputFiles foreigns = do
let testFile = last inputFiles
liftIO . putStrLn $ "Assert " ++ testFile ++ " does not compile"
@@ -242,7 +209,9 @@ fetchSupportCode :: IO ()
fetchSupportCode = do
setCurrentDirectory "tests/support"
callProcess "npm" ["install"]
- callProcess "bower" ["install"]
+ -- Sometimes we run as a root (e.g. in simple docker containers)
+ -- And we are non-interactive: https://github.com/bower/bower/issues/1162
+ callProcess "node_modules/.bin/bower" ["--allow-root", "install", "--config.interactive=false"]
callProcess "node" ["setup.js"]
setCurrentDirectory "../.."
diff --git a/tests/support/bower.json b/tests/support/bower.json
new file mode 100644
index 0000000..9d1b7d2
--- /dev/null
+++ b/tests/support/bower.json
@@ -0,0 +1,11 @@
+{
+ "name": "purescript-test-suite-support",
+ "dependencies": {
+ "purescript-eff": "0.1.0",
+ "purescript-prelude": "0.1.1",
+ "purescript-assert": "0.1.1",
+ "purescript-st": "0.1.0",
+ "purescript-console": "0.1.0",
+ "purescript-functions": "0.1.0"
+ }
+}
diff --git a/tests/support/flattened/Control-Monad-Eff-Class.purs b/tests/support/flattened/Control-Monad-Eff-Class.purs
deleted file mode 100644
index dbfd58e..0000000
--- a/tests/support/flattened/Control-Monad-Eff-Class.purs
+++ /dev/null
@@ -1,24 +0,0 @@
-module Control.Monad.Eff.Class
- ( MonadEff
- , liftEff
- ) where
-
-import Prelude
-
-import Control.Monad.Eff
-
--- | The `MonadEff` class captures those monads which support native effects.
--- |
--- | Instances are provided for `Eff` itself, and the standard monad transformers.
--- |
--- | `liftEff` can be used in any appropriate monad transformer stack to lift an action
--- | of type `Eff eff a` into the monad.
--- |
--- | Note that `MonadEff` is parameterized by the row of effects, so type inference can be
--- | tricky. It is generally recommended to either work with a polymorphic row of effects,
--- | or a concrete, closed row of effects such as `(trace :: Trace)`.
-class (Monad m) <= MonadEff eff m where
- liftEff :: forall a. Eff eff a -> m a
-
-instance monadEffEff :: MonadEff eff (Eff eff) where
- liftEff = id
diff --git a/tests/support/flattened/Control-Monad-Eff-Console.js b/tests/support/flattened/Control-Monad-Eff-Console.js
deleted file mode 100644
index 9ccfc26..0000000
--- a/tests/support/flattened/Control-Monad-Eff-Console.js
+++ /dev/null
@@ -1,18 +0,0 @@
-/* global exports, console */
-"use strict";
-
-// module Control.Monad.Eff.Console
-
-exports.log = function (s) {
- return function () {
- console.log(s);
- return {};
- };
-};
-
-exports.error = function (s) {
- return function () {
- console.error(s);
- return {};
- };
-};
diff --git a/tests/support/flattened/Control-Monad-Eff-Console.purs b/tests/support/flattened/Control-Monad-Eff-Console.purs
deleted file mode 100644
index 0a03ee4..0000000
--- a/tests/support/flattened/Control-Monad-Eff-Console.purs
+++ /dev/null
@@ -1,18 +0,0 @@
-module Control.Monad.Eff.Console where
-
-import Prelude
-
-import Control.Monad.Eff
-
--- | The `CONSOLE` effect represents those computations which write to the console.
-foreign import data CONSOLE :: !
-
--- | Write a message to the console.
-foreign import log :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit
-
--- | Write an error to the console.
-foreign import error :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit
-
--- | Write a value to the console, using its `Show` instance to produce a `String`.
-print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit
-print = log <<< show
diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.js b/tests/support/flattened/Control-Monad-Eff-Unsafe.js
deleted file mode 100644
index bada18a..0000000
--- a/tests/support/flattened/Control-Monad-Eff-Unsafe.js
+++ /dev/null
@@ -1,8 +0,0 @@
-/* global exports */
-"use strict";
-
-// module Control.Monad.Eff.Unsafe
-
-exports.unsafeInterleaveEff = function (f) {
- return f;
-};
diff --git a/tests/support/flattened/Control-Monad-Eff-Unsafe.purs b/tests/support/flattened/Control-Monad-Eff-Unsafe.purs
deleted file mode 100644
index 5d6f104..0000000
--- a/tests/support/flattened/Control-Monad-Eff-Unsafe.purs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Control.Monad.Eff.Unsafe where
-
-import Prelude
-
-import Control.Monad.Eff
-
--- | Change the type of an effectful computation, allowing it to be run in another context.
--- |
--- | Note: use of this function can result in arbitrary side-effects.
-foreign import unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
diff --git a/tests/support/flattened/Control-Monad-Eff.js b/tests/support/flattened/Control-Monad-Eff.js
deleted file mode 100644
index 1498f21..0000000
--- a/tests/support/flattened/Control-Monad-Eff.js
+++ /dev/null
@@ -1,62 +0,0 @@
-/* global exports */
-"use strict";
-
-// module Control.Monad.Eff
-
-exports.returnE = function (a) {
- return function () {
- return a;
- };
-};
-
-exports.bindE = function (a) {
- return function (f) {
- return function () {
- return f(a())();
- };
- };
-};
-
-exports.runPure = function (f) {
- return f();
-};
-
-exports.untilE = function (f) {
- return function () {
- while (!f());
- return {};
- };
-};
-
-exports.whileE = function (f) {
- return function (a) {
- return function () {
- while (f()) {
- a();
- }
- return {};
- };
- };
-};
-
-exports.forE = function (lo) {
- return function (hi) {
- return function (f) {
- return function () {
- for (var i = lo; i < hi; i++) {
- f(i)();
- }
- };
- };
- };
-};
-
-exports.foreachE = function (as) {
- return function (f) {
- return function () {
- for (var i = 0, l = as.length; i < l; i++) {
- f(as[i])();
- }
- };
- };
-};
diff --git a/tests/support/flattened/Control-Monad-Eff.purs b/tests/support/flattened/Control-Monad-Eff.purs
deleted file mode 100644
index 0417c19..0000000
--- a/tests/support/flattened/Control-Monad-Eff.purs
+++ /dev/null
@@ -1,67 +0,0 @@
-module Control.Monad.Eff
- ( Eff()
- , Pure()
- , runPure
- , untilE, whileE, forE, foreachE
- ) where
-
-import Prelude
-
--- | The `Eff` type constructor is used to represent _native_ effects.
--- |
--- | See [Handling Native Effects with the Eff Monad](https://github.com/purescript/purescript/wiki/Handling-Native-Effects-with-the-Eff-Monad) for more details.
--- |
--- | The first type parameter is a row of effects which represents the contexts in which a computation can be run, and the second type parameter is the return type.
-foreign import data Eff :: # ! -> * -> *
-
-foreign import returnE :: forall e a. a -> Eff e a
-
-foreign import bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
-
--- | The `Pure` type synonym represents _pure_ computations, i.e. ones in which all effects have been handled.
--- |
--- | The `runPure` function can be used to run pure computations and obtain their result.
-type Pure a = forall e. Eff e a
-
--- | Run a pure computation and return its result.
--- |
--- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
--- | is to use parentheses instead.
-foreign import runPure :: forall a. Pure a -> a
-
-instance functorEff :: Functor (Eff e) where
- map = liftA1
-
-instance applyEff :: Apply (Eff e) where
- apply = ap
-
-instance applicativeEff :: Applicative (Eff e) where
- pure = returnE
-
-instance bindEff :: Bind (Eff e) where
- bind = bindE
-
-instance monadEff :: Monad (Eff e)
-
--- | Loop until a condition becomes `true`.
--- |
--- | `untilE b` is an effectful computation which repeatedly runs the effectful computation `b`,
--- | until its return value is `true`.
-foreign import untilE :: forall e. Eff e Boolean -> Eff e Unit
-
--- | Loop while a condition is `true`.
--- |
--- | `whileE b m` is effectful computation which runs the effectful computation `b`. If its result is
--- | `true`, it runs the effectful computation `m` and loops. If not, the computation ends.
-foreign import whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
-
--- | Loop over a consecutive collection of numbers.
--- |
--- | `forE lo hi f` runs the computation returned by the function `f` for each of the inputs
--- | between `lo` (inclusive) and `hi` (exclusive).
-foreign import forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
-
--- | Loop over an array of values.
--- |
--- | `foreach xs f` runs the computation returned by the function `f` for each of the inputs `xs`.
-foreign import foreachE :: forall e a. Array a -> (a -> Eff e Unit) -> Eff e Unit
diff --git a/tests/support/flattened/Control-Monad-ST.js b/tests/support/flattened/Control-Monad-ST.js
deleted file mode 100644
index 64597c1..0000000
--- a/tests/support/flattened/Control-Monad-ST.js
+++ /dev/null
@@ -1,38 +0,0 @@
-/* global exports */
-"use strict";
-
-// module Control.Monad.ST
-
-exports.newSTRef = function (val) {
- return function () {
- return { value: val };
- };
-};
-
-exports.readSTRef = function (ref) {
- return function () {
- return ref.value;
- };
-};
-
-exports.modifySTRef = function (ref) {
- return function (f) {
- return function () {
- /* jshint boss: true */
- return ref.value = f(ref.value);
- };
- };
-};
-
-exports.writeSTRef = function (ref) {
- return function (a) {
- return function () {
- /* jshint boss: true */
- return ref.value = a;
- };
- };
-};
-
-exports.runST = function (f) {
- return f;
-};
diff --git a/tests/support/flattened/Control-Monad-ST.purs b/tests/support/flattened/Control-Monad-ST.purs
deleted file mode 100644
index ac113e5..0000000
--- a/tests/support/flattened/Control-Monad-ST.purs
+++ /dev/null
@@ -1,42 +0,0 @@
-module Control.Monad.ST where
-
-import Prelude
-
-import Control.Monad.Eff (Eff(), runPure)
-
--- | The `ST` effect represents _local mutation_, i.e. mutation which does not "escape" into the surrounding computation.
--- |
--- | An `ST` computation is parameterized by a phantom type which is used to restrict the set of reference cells it is allowed to access.
--- |
--- | The `runST` function can be used to handle the `ST` effect.
-foreign import data ST :: * -> !
-
--- | The type `STRef s a` represents a mutable reference holding a value of type `a`, which can be used with the `ST s` effect.
-foreign import data STRef :: * -> * -> *
-
--- | Create a new mutable reference.
-foreign import newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
-
--- | Read the current value of a mutable reference.
-foreign import readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
-
--- | Modify the value of a mutable reference by applying a function to the current value.
-foreign import modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
-
--- | Set the value of a mutable reference.
-foreign import writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
-
--- | Run an `ST` computation.
--- |
--- | Note: the type of `runST` uses a rank-2 type to constrain the phantom type `s`, such that the computation must not leak any mutable references
--- | to the surrounding computation.
--- |
--- | It may cause problems to apply this function using the `$` operator. The recommended approach is to use parentheses instead.
-foreign import runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
-
--- | A convenience function which combines `runST` with `runPure`, which can be used when the only required effect is `ST`.
--- |
--- | Note: since this function has a rank-2 type, it may cause problems to apply this function using the `$` operator. The recommended approach
--- | is to use parentheses instead.
-pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
-pureST st = runPure (runST st)
diff --git a/tests/support/flattened/Data-Function.js b/tests/support/flattened/Data-Function.js
deleted file mode 100644
index 0d6d0f4..0000000
--- a/tests/support/flattened/Data-Function.js
+++ /dev/null
@@ -1,233 +0,0 @@
-/* global exports */
-"use strict";
-
-// module Data.Function
-
-exports.mkFn0 = function (fn) {
- return function () {
- return fn({});
- };
-};
-
-exports.mkFn1 = function (fn) {
- return function (a) {
- return fn(a);
- };
-};
-
-exports.mkFn2 = function (fn) {
- /* jshint maxparams: 2 */
- return function (a, b) {
- return fn(a)(b);
- };
-};
-
-exports.mkFn3 = function (fn) {
- /* jshint maxparams: 3 */
- return function (a, b, c) {
- return fn(a)(b)(c);
- };
-};
-
-exports.mkFn4 = function (fn) {
- /* jshint maxparams: 4 */
- return function (a, b, c, d) {
- return fn(a)(b)(c)(d);
- };
-};
-
-exports.mkFn5 = function (fn) {
- /* jshint maxparams: 5 */
- return function (a, b, c, d, e) {
- return fn(a)(b)(c)(d)(e);
- };
-};
-
-exports.mkFn6 = function (fn) {
- /* jshint maxparams: 6 */
- return function (a, b, c, d, e, f) {
- return fn(a)(b)(c)(d)(e)(f);
- };
-};
-
-exports.mkFn7 = function (fn) {
- /* jshint maxparams: 7 */
- return function (a, b, c, d, e, f, g) {
- return fn(a)(b)(c)(d)(e)(f)(g);
- };
-};
-
-exports.mkFn8 = function (fn) {
- /* jshint maxparams: 8 */
- return function (a, b, c, d, e, f, g, h) {
- return fn(a)(b)(c)(d)(e)(f)(g)(h);
- };
-};
-
-exports.mkFn9 = function (fn) {
- /* jshint maxparams: 9 */
- return function (a, b, c, d, e, f, g, h, i) {
- return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);
- };
-};
-
-exports.mkFn10 = function (fn) {
- /* jshint maxparams: 10 */
- return function (a, b, c, d, e, f, g, h, i, j) {
- return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);
- };
-};
-
-exports.runFn0 = function (fn) {
- return fn();
-};
-
-exports.runFn1 = function (fn) {
- return function (a) {
- return fn(a);
- };
-};
-
-exports.runFn2 = function (fn) {
- return function (a) {
- return function (b) {
- return fn(a, b);
- };
- };
-};
-
-exports.runFn3 = function (fn) {
- return function (a) {
- return function (b) {
- return function (c) {
- return fn(a, b, c);
- };
- };
- };
-};
-
-exports.runFn4 = function (fn) {
- return function (a) {
- return function (b) {
- return function (c) {
- return function (d) {
- return fn(a, b, c, d);
- };
- };
- };
- };
-};
-
-exports.runFn5 = function (fn) {
- return function (a) {
- return function (b) {
- return function (c) {
- return function (d) {
- return function (e) {
- return fn(a, b, c, d, e);
- };
- };
- };
- };
- };
-};
-
-exports.runFn6 = function (fn) {
- return function (a) {
- return function (b) {
- return function (c) {
- return function (d) {
- return function (e) {
- return function (f) {
- return fn(a, b, c, d, e, f);
- };
- };
- };
- };
- };
- };
-};
-
-exports.runFn7 = function (fn) {
- return function (a) {
- return function (b) {
- return function (c) {
- return function (d) {
- return function (e) {
- return function (f) {
- return function (g) {
- return fn(a, b, c, d, e, f, g);
- };
- };
- };
- };
- };
- };
- };
-};
-
-exports.runFn8 = function (fn) {
- return function (a) {
- return function (b) {
- return function (c) {
- return function (d) {
- return function (e) {
- return function (f) {
- return function (g) {
- return function (h) {
- return fn(a, b, c, d, e, f, g, h);
- };
- };
- };
- };
- };
- };
- };
- };
-};
-
-exports.runFn9 = function (fn) {
- return function (a) {
- return function (b) {
- return function (c) {
- return function (d) {
- return function (e) {
- return function (f) {
- return function (g) {
- return function (h) {
- return function (i) {
- return fn(a, b, c, d, e, f, g, h, i);
- };
- };
- };
- };
- };
- };
- };
- };
- };
-};
-
-exports.runFn10 = function (fn) {
- return function (a) {
- return function (b) {
- return function (c) {
- return function (d) {
- return function (e) {
- return function (f) {
- return function (g) {
- return function (h) {
- return function (i) {
- return function (j) {
- return fn(a, b, c, d, e, f, g, h, i, j);
- };
- };
- };
- };
- };
- };
- };
- };
- };
- };
-};
diff --git a/tests/support/flattened/Data-Function.purs b/tests/support/flattened/Data-Function.purs
deleted file mode 100644
index 37ceca1..0000000
--- a/tests/support/flattened/Data-Function.purs
+++ /dev/null
@@ -1,113 +0,0 @@
-module Data.Function where
-
-import Prelude
-
--- | The `on` function is used to change the domain of a binary operator.
--- |
--- | For example, we can create a function which compares two records based on the values of their `x` properties:
--- |
--- | ```purescript
--- | compareX :: forall r. { x :: Number | r } -> { x :: Number | r } -> Ordering
--- | compareX = compare `on` _.x
--- | ```
-on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
-on f g x y = g x `f` g y
-
--- | A function of zero arguments
-foreign import data Fn0 :: * -> *
-
--- | A function of one argument
-foreign import data Fn1 :: * -> * -> *
-
--- | A function of two arguments
-foreign import data Fn2 :: * -> * -> * -> *
-
--- | A function of three arguments
-foreign import data Fn3 :: * -> * -> * -> * -> *
-
--- | A function of four arguments
-foreign import data Fn4 :: * -> * -> * -> * -> * -> *
-
--- | A function of five arguments
-foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
-
--- | A function of six arguments
-foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
-
--- | A function of seven arguments
-foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
-
--- | A function of eight arguments
-foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
-
--- | A function of nine arguments
-foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
-
--- | A function of ten arguments
-foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
-
--- | Create a function of no arguments
-foreign import mkFn0 :: forall a. (Unit -> a) -> Fn0 a
-
--- | Create a function of one argument
-foreign import mkFn1 :: forall a b. (a -> b) -> Fn1 a b
-
--- | Create a function of two arguments from a curried function
-foreign import mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c
-
--- | Create a function of three arguments from a curried function
-foreign import mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
-
--- | Create a function of four arguments from a curried function
-foreign import mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
-
--- | Create a function of five arguments from a curried function
-foreign import mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
-
--- | Create a function of six arguments from a curried function
-foreign import mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
-
--- | Create a function of seven arguments from a curried function
-foreign import mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
-
--- | Create a function of eight arguments from a curried function
-foreign import mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
-
--- | Create a function of nine arguments from a curried function
-foreign import mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
-
--- | Create a function of ten arguments from a curried function
-foreign import mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
-
--- | Apply a function of no arguments
-foreign import runFn0 :: forall a. Fn0 a -> a
-
--- | Apply a function of one argument
-foreign import runFn1 :: forall a b. Fn1 a b -> a -> b
-
--- | Apply a function of two arguments
-foreign import runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c
-
--- | Apply a function of three arguments
-foreign import runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
-
--- | Apply a function of four arguments
-foreign import runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
-
--- | Apply a function of five arguments
-foreign import runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
-
--- | Apply a function of six arguments
-foreign import runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
-
--- | Apply a function of seven arguments
-foreign import runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
-
--- | Apply a function of eight arguments
-foreign import runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
-
--- | Apply a function of nine arguments
-foreign import runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
-
--- | Apply a function of ten arguments
-foreign import runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
diff --git a/tests/support/flattened/Prelude.js b/tests/support/flattened/Prelude.js
deleted file mode 100644
index 6e4d364..0000000
--- a/tests/support/flattened/Prelude.js
+++ /dev/null
@@ -1,222 +0,0 @@
-/* global exports */
-"use strict";
-
-// module Prelude
-
-//- Functor --------------------------------------------------------------------
-
-exports.arrayMap = function (f) {
- return function (arr) {
- var l = arr.length;
- var result = new Array(l);
- for (var i = 0; i < l; i++) {
- result[i] = f(arr[i]);
- }
- return result;
- };
-};
-
-//- Bind -----------------------------------------------------------------------
-
-exports.arrayBind = function (arr) {
- return function (f) {
- var result = [];
- for (var i = 0, l = arr.length; i < l; i++) {
- Array.prototype.push.apply(result, f(arr[i]));
- }
- return result;
- };
-};
-
-//- Monoid ---------------------------------------------------------------------
-
-exports.concatString = function (s1) {
- return function (s2) {
- return s1 + s2;
- };
-};
-
-exports.concatArray = function (xs) {
- return function (ys) {
- return xs.concat(ys);
- };
-};
-
-//- Semiring -------------------------------------------------------------------
-
-exports.intAdd = function (x) {
- return function (y) {
- /* jshint bitwise: false */
- return x + y | 0;
- };
-};
-
-exports.intMul = function (x) {
- return function (y) {
- /* jshint bitwise: false */
- return x * y | 0;
- };
-};
-
-exports.numAdd = function (n1) {
- return function (n2) {
- return n1 + n2;
- };
-};
-
-exports.numMul = function (n1) {
- return function (n2) {
- return n1 * n2;
- };
-};
-
-//- ModuloSemiring -------------------------------------------------------------
-
-exports.intDiv = function (x) {
- return function (y) {
- /* jshint bitwise: false */
- return x / y | 0;
- };
-};
-
-exports.intMod = function (x) {
- return function (y) {
- return x % y;
- };
-};
-
-exports.numDiv = function (n1) {
- return function (n2) {
- return n1 / n2;
- };
-};
-
-//- Ring -----------------------------------------------------------------------
-
-exports.intSub = function (x) {
- return function (y) {
- /* jshint bitwise: false */
- return x - y | 0;
- };
-};
-
-exports.numSub = function (n1) {
- return function (n2) {
- return n1 - n2;
- };
-};
-
-//- Eq -------------------------------------------------------------------------
-
-exports.refEq = function (r1) {
- return function (r2) {
- return r1 === r2;
- };
-};
-
-exports.refIneq = function (r1) {
- return function (r2) {
- return r1 !== r2;
- };
-};
-
-exports.eqArrayImpl = function (f) {
- return function (xs) {
- return function (ys) {
- if (xs.length !== ys.length) return false;
- for (var i = 0; i < xs.length; i++) {
- if (!f(xs[i])(ys[i])) return false;
- }
- return true;
- };
- };
-};
-
-exports.ordArrayImpl = function (f) {
- return function (xs) {
- return function (ys) {
- var i = 0;
- var xlen = xs.length;
- var ylen = ys.length;
- while (i < xlen && i < ylen) {
- var x = xs[i];
- var y = ys[i];
- var o = f(x)(y);
- if (o !== 0) {
- return o;
- }
- i++;
- }
- if (xlen === ylen) {
- return 0;
- } else if (xlen > ylen) {
- return -1;
- } else {
- return 1;
- }
- };
- };
-};
-
-//- Ord ------------------------------------------------------------------------
-
-exports.unsafeCompareImpl = function (lt) {
- return function (eq) {
- return function (gt) {
- return function (x) {
- return function (y) {
- return x < y ? lt : x > y ? gt : eq;
- };
- };
- };
- };
-};
-
-//- Lattice --------------------------------------------------------------------
-
-exports.boolOr = function (b1) {
- return function (b2) {
- return b1 || b2;
- };
-};
-
-exports.boolAnd = function (b1) {
- return function (b2) {
- return b1 && b2;
- };
-};
-
-//- ComplementedLattice --------------------------------------------------------
-
-exports.boolNot = function (b) {
- return !b;
-};
-
-//- Show -----------------------------------------------------------------------
-
-exports.showIntImpl = function (n) {
- return n.toString();
-};
-
-exports.showNumberImpl = function (n) {
- /* jshint bitwise: false */
- return n === (n | 0) ? n + ".0" : n.toString();
-};
-
-exports.showCharImpl = function (c) {
- return c === "'" ? "'\\''" : "'" + c + "'";
-};
-
-exports.showStringImpl = function (s) {
- return JSON.stringify(s);
-};
-
-exports.showArrayImpl = function (f) {
- return function (xs) {
- var ss = [];
- for (var i = 0, l = xs.length; i < l; i++) {
- ss[i] = f(xs[i]);
- }
- return "[" + ss.join(",") + "]";
- };
-};
diff --git a/tests/support/flattened/Prelude.purs b/tests/support/flattened/Prelude.purs
deleted file mode 100644
index 6c06c5f..0000000
--- a/tests/support/flattened/Prelude.purs
+++ /dev/null
@@ -1,860 +0,0 @@
-module Prelude
- ( Unit(), unit
- , ($), (#)
- , flip
- , const
- , asTypeOf
- , otherwise
- , Semigroupoid, compose, (<<<), (>>>)
- , Category, id
- , Functor, map, (<$>), (<#>), void
- , Apply, apply, (<*>)
- , Applicative, pure, liftA1
- , Bind, bind, (>>=)
- , Monad, return, liftM1, ap
- , Semigroup, append, (<>), (++)
- , Semiring, add, zero, mul, one, (+), (*)
- , ModuloSemiring, div, mod, (/)
- , Ring, sub, negate, (-)
- , Num
- , DivisionRing
- , Eq, eq, (==), (/=)
- , Ordering(..), Ord, compare, (<), (>), (<=), (>=)
- , unsafeCompare
- , Bounded, top, bottom
- , BoundedOrd
- , BooleanAlgebra, conj, disj, not, (&&), (||)
- , Show, show
- ) where
-
--- | The `Unit` type has a single inhabitant, called `unit`. It represents
--- | values with no computational content.
--- |
--- | `Unit` is often used, wrapped in a monadic type constructor, as the
--- | return type of a computation where only
--- | the _effects_ are important.
-newtype Unit = Unit {}
-
--- | `unit` is the sole inhabitant of the `Unit` type.
-unit :: Unit
-unit = Unit {}
-
-infixr 0 $
-infixl 1 #
-
--- | Applies a function to its argument.
--- |
--- | ```purescript
--- | length $ groupBy productCategory $ filter isInStock $ products
--- | ```
--- |
--- | is equivalent to:
--- |
--- | ```purescript
--- | length (groupBy productCategory (filter isInStock products))
--- | ```
--- |
--- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of
--- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))`
-($) :: forall a b. (a -> b) -> a -> b
-($) f x = f x
-
--- | Applies an argument to a function.
--- |
--- | ```purescript
--- | products # filter isInStock # groupBy productCategory # length
--- | ```
--- |
--- | is equivalent to:
--- |
--- | ```purescript
--- | length (groupBy productCategory (filter isInStock products))
--- | ```
--- |
--- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of
--- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))`
-(#) :: forall a b. a -> (a -> b) -> b
-(#) x f = f x
-
--- | Flips the order of the arguments to a function of two arguments.
--- |
--- | ```purescript
--- | flip const 1 2 = const 2 1 = 2
--- | ```
-flip :: forall a b c. (a -> b -> c) -> b -> a -> c
-flip f b a = f a b
-
--- | Returns its first argument and ignores its second.
--- |
--- | ```purescript
--- | const 1 "hello" = 1
--- | ```
-const :: forall a b. a -> b -> a
-const a _ = a
-
--- | This function returns its first argument, and can be used to assert type
--- | equalities. This can be useful when types are otherwise ambiguous.
--- |
--- | ```purescript
--- | main = print $ [] `asTypeOf` [0]
--- | ```
--- |
--- | If instead, we had written `main = print []`, the type of the argument
--- | `[]` would have been ambiguous, resulting in a compile-time error.
-asTypeOf :: forall a. a -> a -> a
-asTypeOf x _ = x
-
--- | An alias for `true`, which can be useful in guard clauses:
--- |
--- | ```purescript
--- | max x y | x >= y = x
--- | | otherwise = y
--- | ```
-otherwise :: Boolean
-otherwise = true
-
--- | A `Semigroupoid` is similar to a [`Category`](#category) but does not
--- | require an identity element `id`, just composable morphisms.
--- |
--- | `Semigroupoid`s must satisfy the following law:
--- |
--- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`
--- |
--- | One example of a `Semigroupoid` is the function type constructor `(->)`,
--- | with `(<<<)` defined as function composition.
-class Semigroupoid a where
- compose :: forall b c d. a c d -> a b c -> a b d
-
-instance semigroupoidFn :: Semigroupoid (->) where
- compose f g x = f (g x)
-
-infixr 9 >>>
-infixr 9 <<<
-
--- | `(<<<)` is an alias for `compose`.
-(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d
-(<<<) = compose
-
--- | Forwards composition, or `(<<<)` with its arguments reversed.
-(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
-(>>>) = flip compose
-
--- | `Category`s consist of objects and composable morphisms between them, and
--- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids`
--- | must have an identity element.
--- |
--- | Instances must satisfy the following law in addition to the
--- | `Semigroupoid` law:
--- |
--- | - Identity: `id <<< p = p <<< id = p`
-class (Semigroupoid a) <= Category a where
- id :: forall t. a t t
-
-instance categoryFn :: Category (->) where
- id x = x
-
--- | A `Functor` is a type constructor which supports a mapping operation
--- | `(<$>)`.
--- |
--- | `(<$>)` can be used to turn functions `a -> b` into functions
--- | `f a -> f b` whose argument and return types use the type constructor `f`
--- | to represent some computational context.
--- |
--- | Instances must satisfy the following laws:
--- |
--- | - Identity: `(<$>) id = id`
--- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`
-class Functor f where
- map :: forall a b. (a -> b) -> f a -> f b
-
-instance functorFn :: Functor ((->) r) where
- map = compose
-
-instance functorArray :: Functor Array where
- map = arrayMap
-
-foreign import arrayMap :: forall a b. (a -> b) -> Array a -> Array b
-
-infixl 4 <$>
-infixl 1 <#>
-
--- | `(<$>)` is an alias for `map`
-(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
-(<$>) = map
-
--- | `(<#>)` is `(<$>)` with its arguments reversed. For example:
--- |
--- | ```purescript
--- | [1, 2, 3] <#> \n -> n * n
--- | ```
-(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
-(<#>) fa f = f <$> fa
-
--- | The `void` function is used to ignore the type wrapped by a
--- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type
--- | information provided by the type constructor itself.
--- |
--- | `void` is often useful when using `do` notation to change the return type
--- | of a monadic computation:
--- |
--- | ```purescript
--- | main = forE 1 10 \n -> void do
--- | print n
--- | print (n * n)
--- | ```
-void :: forall f a. (Functor f) => f a -> f Unit
-void fa = const unit <$> fa
-
--- | The `Apply` class provides the `(<*>)` which is used to apply a function
--- | to an argument under a type constructor.
--- |
--- | `Apply` can be used to lift functions of two or more arguments to work on
--- | values wrapped with the type constructor `f`. It might also be understood
--- | in terms of the `lift2` function:
--- |
--- | ```purescript
--- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c
--- | lift2 f a b = f <$> a <*> b
--- | ```
--- |
--- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts
--- | the function application operator `($)` to arguments wrapped with the
--- | type constructor `f`.
--- |
--- | Instances must satisfy the following law in addition to the `Functor`
--- | laws:
--- |
--- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
--- |
--- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.
-class (Functor f) <= Apply f where
- apply :: forall a b. f (a -> b) -> f a -> f b
-
-instance applyFn :: Apply ((->) r) where
- apply f g x = f x (g x)
-
-instance applyArray :: Apply Array where
- apply = ap
-
-infixl 4 <*>
-
--- | `(<*>)` is an alias for `apply`.
-(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
-(<*>) = apply
-
--- | The `Applicative` type class extends the [`Apply`](#apply) type class
--- | with a `pure` function, which can be used to create values of type `f a`
--- | from values of type `a`.
--- |
--- | Where [`Apply`](#apply) provides the ability to lift functions of two or
--- | more arguments to functions whose arguments are wrapped using `f`, and
--- | [`Functor`](#functor) provides the ability to lift functions of one
--- | argument, `pure` can be seen as the function which lifts functions of
--- | _zero_ arguments. That is, `Applicative` functors support a lifting
--- | operation for any number of function arguments.
--- |
--- | Instances must satisfy the following laws in addition to the `Apply`
--- | laws:
--- |
--- | - Identity: `(pure id) <*> v = v`
--- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`
--- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`
--- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`
-class (Apply f) <= Applicative f where
- pure :: forall a. a -> f a
-
-instance applicativeFn :: Applicative ((->) r) where
- pure = const
-
-instance applicativeArray :: Applicative Array where
- pure x = [x]
-
--- | `return` is an alias for `pure`.
-return :: forall m a. (Applicative m) => a -> m a
-return = pure
-
--- | `liftA1` provides a default implementation of `(<$>)` for any
--- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided
--- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass
--- | relationship.
--- |
--- | `liftA1` can therefore be used to write [`Functor`](#functor) instances
--- | as follows:
--- |
--- | ```purescript
--- | instance functorF :: Functor F where
--- | map = liftA1
--- | ```
-liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
-liftA1 f a = pure f <*> a
-
--- | The `Bind` type class extends the [`Apply`](#apply) type class with a
--- | "bind" operation `(>>=)` which composes computations in sequence, using
--- | the return value of one computation to determine the next computation.
--- |
--- | The `>>=` operator can also be expressed using `do` notation, as follows:
--- |
--- | ```purescript
--- | x >>= f = do y <- x
--- | f y
--- | ```
--- |
--- | where the function argument of `f` is given the name `y`.
--- |
--- | Instances must satisfy the following law in addition to the `Apply`
--- | laws:
--- |
--- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`
--- |
--- | Associativity tells us that we can regroup operations which use `do`
--- | notation so that we can unambiguously write, for example:
--- |
--- | ```purescript
--- | do x <- m1
--- | y <- m2 x
--- | m3 x y
--- | ```
-class (Apply m) <= Bind m where
- bind :: forall a b. m a -> (a -> m b) -> m b
-
-instance bindFn :: Bind ((->) r) where
- bind m f x = f (m x) x
-
-instance bindArray :: Bind Array where
- bind = arrayBind
-
-foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b
-
-infixl 1 >>=
-
--- | `(>>=)` is an alias for `bind`.
-(>>=) :: forall m a b. (Bind m) => m a -> (a -> m b) -> m b
-(>>=) = bind
-
--- | The `Monad` type class combines the operations of the `Bind` and
--- | `Applicative` type classes. Therefore, `Monad` instances represent type
--- | constructors which support sequential composition, and also lifting of
--- | functions of arbitrary arity.
--- |
--- | Instances must satisfy the following laws in addition to the
--- | `Applicative` and `Bind` laws:
--- |
--- | - Left Identity: `pure x >>= f = f x`
--- | - Right Identity: `x >>= pure = x`
-class (Applicative m, Bind m) <= Monad m
-
-instance monadFn :: Monad ((->) r)
-instance monadArray :: Monad Array
-
--- | `liftM1` provides a default implementation of `(<$>)` for any
--- | [`Monad`](#monad), without using `(<$>)` as provided by the
--- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
--- |
--- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
--- | as follows:
--- |
--- | ```purescript
--- | instance functorF :: Functor F where
--- | map = liftM1
--- | ```
-liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
-liftM1 f a = do
- a' <- a
- return (f a')
-
--- | `ap` provides a default implementation of `(<*>)` for any
--- | [`Monad`](#monad), without using `(<*>)` as provided by the
--- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
--- |
--- | `ap` can therefore be used to write [`Apply`](#apply) instances as
--- | follows:
--- |
--- | ```purescript
--- | instance applyF :: Apply F where
--- | apply = ap
--- | ```
-ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
-ap f a = do
- f' <- f
- a' <- a
- return (f' a')
-
--- | The `Semigroup` type class identifies an associative operation on a type.
--- |
--- | Instances are required to satisfy the following law:
--- |
--- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
--- |
--- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
--- | concatenation.
-class Semigroup a where
- append :: a -> a -> a
-
-infixr 5 <>
-infixr 5 ++
-
--- | `(<>)` is an alias for `append`.
-(<>) :: forall s. (Semigroup s) => s -> s -> s
-(<>) = append
-
--- | `(++)` is an alternative alias for `append`.
-(++) :: forall s. (Semigroup s) => s -> s -> s
-(++) = append
-
-instance semigroupString :: Semigroup String where
- append = concatString
-
-instance semigroupUnit :: Semigroup Unit where
- append _ _ = unit
-
-instance semigroupFn :: (Semigroup s') => Semigroup (s -> s') where
- append f g = \x -> f x <> g x
-
-instance semigroupOrdering :: Semigroup Ordering where
- append LT _ = LT
- append GT _ = GT
- append EQ y = y
-
-instance semigroupArray :: Semigroup (Array a) where
- append = concatArray
-
-foreign import concatString :: String -> String -> String
-foreign import concatArray :: forall a. Array a -> Array a -> Array a
-
--- | The `Semiring` class is for types that support an addition and
--- | multiplication operation.
--- |
--- | Instances must satisfy the following laws:
--- |
--- | - Commutative monoid under addition:
--- | - Associativity: `(a + b) + c = a + (b + c)`
--- | - Identity: `zero + a = a + zero = a`
--- | - Commutative: `a + b = b + a`
--- | - Monoid under multiplication:
--- | - Associativity: `(a * b) * c = a * (b * c)`
--- | - Identity: `one * a = a * one = a`
--- | - Multiplication distributes over addition:
--- | - Left distributivity: `a * (b + c) = (a * b) + (a * c)`
--- | - Right distributivity: `(a + b) * c = (a * c) + (b * c)`
--- | - Annihiliation: `zero * a = a * zero = zero`
-class Semiring a where
- add :: a -> a -> a
- zero :: a
- mul :: a -> a -> a
- one :: a
-
-instance semiringInt :: Semiring Int where
- add = intAdd
- zero = 0
- mul = intMul
- one = 1
-
-instance semiringNumber :: Semiring Number where
- add = numAdd
- zero = 0.0
- mul = numMul
- one = 1.0
-
-instance semiringUnit :: Semiring Unit where
- add _ _ = unit
- zero = unit
- mul _ _ = unit
- one = unit
-
-infixl 6 +
-infixl 7 *
-
--- | `(+)` is an alias for `add`.
-(+) :: forall a. (Semiring a) => a -> a -> a
-(+) = add
-
--- | `(*)` is an alias for `mul`.
-(*) :: forall a. (Semiring a) => a -> a -> a
-(*) = mul
-
-foreign import intAdd :: Int -> Int -> Int
-foreign import intMul :: Int -> Int -> Int
-foreign import numAdd :: Number -> Number -> Number
-foreign import numMul :: Number -> Number -> Number
-
--- | The `Ring` class is for types that support addition, multiplication,
--- | and subtraction operations.
--- |
--- | Instances must satisfy the following law in addition to the `Semiring`
--- | laws:
--- |
--- | - Additive inverse: `a - a = (zero - a) + a = zero`
-class (Semiring a) <= Ring a where
- sub :: a -> a -> a
-
-instance ringInt :: Ring Int where
- sub = intSub
-
-instance ringNumber :: Ring Number where
- sub = numSub
-
-instance ringUnit :: Ring Unit where
- sub _ _ = unit
-
-infixl 6 -
-
--- | `(-)` is an alias for `sub`.
-(-) :: forall a. (Ring a) => a -> a -> a
-(-) = sub
-
--- | `negate x` can be used as a shorthand for `zero - x`.
-negate :: forall a. (Ring a) => a -> a
-negate a = zero - a
-
-foreign import intSub :: Int -> Int -> Int
-foreign import numSub :: Number -> Number -> Number
-
--- | The `ModuloSemiring` class is for types that support addition,
--- | multiplication, division, and modulo (division remainder) operations.
--- |
--- | Instances must satisfy the following law in addition to the `Semiring`
--- | laws:
--- |
--- | - Remainder: `a / b * b + (a `mod` b) = a`
-class (Semiring a) <= ModuloSemiring a where
- div :: a -> a -> a
- mod :: a -> a -> a
-
-instance moduloSemiringInt :: ModuloSemiring Int where
- div = intDiv
- mod = intMod
-
-instance moduloSemiringNumber :: ModuloSemiring Number where
- div = numDiv
- mod _ _ = 0.0
-
-instance moduloSemiringUnit :: ModuloSemiring Unit where
- div _ _ = unit
- mod _ _ = unit
-
-infixl 7 /
-
--- | `(/)` is an alias for `div`.
-(/) :: forall a. (ModuloSemiring a) => a -> a -> a
-(/) = div
-
-foreign import intDiv :: Int -> Int -> Int
-foreign import numDiv :: Number -> Number -> Number
-foreign import intMod :: Int -> Int -> Int
-
--- | A `Ring` where every nonzero element has a multiplicative inverse.
--- |
--- | Instances must satisfy the following law in addition to the `Ring` and
--- | `ModuloSemiring` laws:
--- |
--- | - Multiplicative inverse: `(one / x) * x = one`
--- |
--- | As a consequence of this ```a `mod` b = zero``` as no divide operation
--- | will have a remainder.
-class (Ring a, ModuloSemiring a) <= DivisionRing a
-
-instance divisionRingNumber :: DivisionRing Number
-instance divisionRingUnit :: DivisionRing Unit
-
--- | The `Num` class is for types that are commutative fields.
--- |
--- | Instances must satisfy the following law in addition to the
--- | `DivisionRing` laws:
--- |
--- | - Commutative multiplication: `a * b = b * a`
-class (DivisionRing a) <= Num a
-
-instance numNumber :: Num Number
-instance numUnit :: Num Unit
-
--- | The `Eq` type class represents types which support decidable equality.
--- |
--- | `Eq` instances should satisfy the following laws:
--- |
--- | - Reflexivity: `x == x = true`
--- | - Symmetry: `x == y = y == x`
--- | - Transitivity: if `x == y` and `y == z` then `x == z`
-class Eq a where
- eq :: a -> a -> Boolean
-
-infix 4 ==
-infix 4 /=
-
--- | `(==)` is an alias for `eq`. Tests whether one value is equal to another.
-(==) :: forall a. (Eq a) => a -> a -> Boolean
-(==) = eq
-
--- | `(/=)` tests whether one value is _not equal_ to another. Shorthand for
--- | `not (x == y)`.
-(/=) :: forall a. (Eq a) => a -> a -> Boolean
-(/=) x y = not (x == y)
-
-instance eqBoolean :: Eq Boolean where
- eq = refEq
-
-instance eqInt :: Eq Int where
- eq = refEq
-
-instance eqNumber :: Eq Number where
- eq = refEq
-
-instance eqChar :: Eq Char where
- eq = refEq
-
-instance eqString :: Eq String where
- eq = refEq
-
-instance eqUnit :: Eq Unit where
- eq _ _ = true
-
-instance eqArray :: (Eq a) => Eq (Array a) where
- eq = eqArrayImpl (==)
-
-instance eqOrdering :: Eq Ordering where
- eq LT LT = true
- eq GT GT = true
- eq EQ EQ = true
- eq _ _ = false
-
-foreign import refEq :: forall a. a -> a -> Boolean
-foreign import refIneq :: forall a. a -> a -> Boolean
-foreign import eqArrayImpl :: forall a. (a -> a -> Boolean) -> Array a -> Array a -> Boolean
-
--- | The `Ordering` data type represents the three possible outcomes of
--- | comparing two values:
--- |
--- | `LT` - The first value is _less than_ the second.
--- | `GT` - The first value is _greater than_ the second.
--- | `EQ` - The first value is _equal to_ the second.
-data Ordering = LT | GT | EQ
-
--- | The `Ord` type class represents types which support comparisons with a
--- | _total order_.
--- |
--- | `Ord` instances should satisfy the laws of total orderings:
--- |
--- | - Reflexivity: `a <= a`
--- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b`
--- | - Transitivity: if `a <= b` and `b <= c` then `a <= c`
-class (Eq a) <= Ord a where
- compare :: a -> a -> Ordering
-
-instance ordBoolean :: Ord Boolean where
- compare = unsafeCompare
-
-instance ordInt :: Ord Int where
- compare = unsafeCompare
-
-instance ordNumber :: Ord Number where
- compare = unsafeCompare
-
-instance ordString :: Ord String where
- compare = unsafeCompare
-
-instance ordChar :: Ord Char where
- compare = unsafeCompare
-
-instance ordUnit :: Ord Unit where
- compare _ _ = EQ
-
-instance ordArray :: (Ord a) => Ord (Array a) where
- compare xs ys = compare 0 $ ordArrayImpl (\x y -> case compare x y of
- EQ -> 0
- LT -> 1
- GT -> -1) xs ys
-
-foreign import ordArrayImpl :: forall a. (a -> a -> Int) -> Array a -> Array a -> Int
-
-instance ordOrdering :: Ord Ordering where
- compare LT LT = EQ
- compare EQ EQ = EQ
- compare GT GT = EQ
- compare LT _ = LT
- compare EQ LT = GT
- compare EQ GT = LT
- compare GT _ = GT
-
-infixl 4 <
-infixl 4 >
-infixl 4 <=
-infixl 4 >=
-
--- | Test whether one value is _strictly less than_ another.
-(<) :: forall a. (Ord a) => a -> a -> Boolean
-(<) a1 a2 = case a1 `compare` a2 of
- LT -> true
- _ -> false
-
--- | Test whether one value is _strictly greater than_ another.
-(>) :: forall a. (Ord a) => a -> a -> Boolean
-(>) a1 a2 = case a1 `compare` a2 of
- GT -> true
- _ -> false
-
--- | Test whether one value is _non-strictly less than_ another.
-(<=) :: forall a. (Ord a) => a -> a -> Boolean
-(<=) a1 a2 = case a1 `compare` a2 of
- GT -> false
- _ -> true
-
--- | Test whether one value is _non-strictly greater than_ another.
-(>=) :: forall a. (Ord a) => a -> a -> Boolean
-(>=) a1 a2 = case a1 `compare` a2 of
- LT -> false
- _ -> true
-
-unsafeCompare :: forall a. a -> a -> Ordering
-unsafeCompare = unsafeCompareImpl LT EQ GT
-
-foreign import unsafeCompareImpl :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
-
--- | The `Bounded` type class represents types that are finite.
--- |
--- | Although there are no "internal" laws for `Bounded`, every value of `a`
--- | should be considered less than or equal to `top` by some means, and greater
--- | than or equal to `bottom`.
--- |
--- | The lack of explicit `Ord` constraint allows flexibility in the use of
--- | `Bounded` so it can apply to total and partially ordered sets, boolean
--- | algebras, etc.
-class Bounded a where
- top :: a
- bottom :: a
-
-instance boundedBoolean :: Bounded Boolean where
- top = true
- bottom = false
-
-instance boundedUnit :: Bounded Unit where
- top = unit
- bottom = unit
-
-instance boundedOrdering :: Bounded Ordering where
- top = GT
- bottom = LT
-
-instance boundedInt :: Bounded Int where
- top = 2147483647
- bottom = -2147483648
-
-instance boundedFn :: (Bounded b) => Bounded (a -> b) where
- top _ = top
- bottom _ = bottom
-
--- | The `BoundedOrd` type class represents totally ordered finite data types.
--- |
--- | Instances should satisfy the following law in addition to the `Ord` laws:
--- |
--- | - Ordering: `bottom <= a <= top`
-class (Bounded a, Ord a) <= BoundedOrd a
-
-instance boundedOrdBoolean :: BoundedOrd Boolean where
-instance boundedOrdUnit :: BoundedOrd Unit where
-instance boundedOrdOrdering :: BoundedOrd Ordering where
-instance boundedOrdInt :: BoundedOrd Int where
-
--- | The `BooleanAlgebra` type class represents types that behave like boolean
--- | values.
--- |
--- | Instances should satisfy the following laws in addition to the `Bounded`
--- | laws:
--- |
--- | - Associativity:
--- | - `a || (b || c) = (a || b) || c`
--- | - `a && (b && c) = (a && b) && c`
--- | - Commutativity:
--- | - `a || b = b || a`
--- | - `a && b = b && a`
--- | - Distributivity:
--- | - `a && (b || c) = (a && b) || (a && c)`
--- | - `a || (b && c) = (a || b) && (a || c)`
--- | - Identity:
--- | - `a || bottom = a`
--- | - `a && top = a`
--- | - Idempotent:
--- | - `a || a = a`
--- | - `a && a = a`
--- | - Absorption:
--- | - `a || (a && b) = a`
--- | - `a && (a || b) = a`
--- | - Annhiliation:
--- | - `a || top = top`
--- | - Complementation:
--- | - `a && not a = bottom`
--- | - `a || not a = top`
-class (Bounded a) <= BooleanAlgebra a where
- conj :: a -> a -> a
- disj :: a -> a -> a
- not :: a -> a
-
-instance booleanAlgebraBoolean :: BooleanAlgebra Boolean where
- conj = boolAnd
- disj = boolOr
- not = boolNot
-
-instance booleanAlgebraUnit :: BooleanAlgebra Unit where
- conj _ _ = unit
- disj _ _ = unit
- not _ = unit
-
-instance booleanAlgebraFn :: (BooleanAlgebra b) => BooleanAlgebra (a -> b) where
- conj fx fy a = fx a `conj` fy a
- disj fx fy a = fx a `disj` fy a
- not fx a = not (fx a)
-
-infixr 3 &&
-infixr 2 ||
-
--- | `(&&)` is an alias for `conj`.
-(&&) :: forall a. (BooleanAlgebra a) => a -> a -> a
-(&&) = conj
-
--- | `(||)` is an alias for `disj`.
-(||) :: forall a. (BooleanAlgebra a) => a -> a -> a
-(||) = disj
-
-foreign import boolOr :: Boolean -> Boolean -> Boolean
-foreign import boolAnd :: Boolean -> Boolean -> Boolean
-foreign import boolNot :: Boolean -> Boolean
-
--- | The `Show` type class represents those types which can be converted into
--- | a human-readable `String` representation.
--- |
--- | While not required, it is recommended that for any expression `x`, the
--- | string `show x` be executable PureScript code which evaluates to the same
--- | value as the expression `x`.
-class Show a where
- show :: a -> String
-
-instance showBoolean :: Show Boolean where
- show true = "true"
- show false = "false"
-
-instance showInt :: Show Int where
- show = showIntImpl
-
-instance showNumber :: Show Number where
- show = showNumberImpl
-
-instance showChar :: Show Char where
- show = showCharImpl
-
-instance showString :: Show String where
- show = showStringImpl
-
-instance showUnit :: Show Unit where
- show _ = "unit"
-
-instance showArray :: (Show a) => Show (Array a) where
- show = showArrayImpl show
-
-instance showOrdering :: Show Ordering where
- show LT = "LT"
- show GT = "GT"
- show EQ = "EQ"
-
-foreign import showIntImpl :: Int -> String
-foreign import showNumberImpl :: Number -> String
-foreign import showCharImpl :: Char -> String
-foreign import showStringImpl :: String -> String
-foreign import showArrayImpl :: forall a. (a -> String) -> Array a -> String
diff --git a/tests/support/flattened/Test-Assert.js b/tests/support/flattened/Test-Assert.js
deleted file mode 100644
index ad1a67c..0000000
--- a/tests/support/flattened/Test-Assert.js
+++ /dev/null
@@ -1,27 +0,0 @@
-/* global exports */
-"use strict";
-
-// module Test.Assert
-
-exports["assert'"] = function (message) {
- return function (success) {
- return function () {
- if (!success) throw new Error(message);
- return {};
- };
- };
-};
-
-exports.checkThrows = function (fn) {
- return function () {
- try {
- fn();
- return false;
- } catch (e) {
- if (e instanceof Error) return true;
- var err = new Error("Threw something other than an Error");
- err.something = e;
- throw err;
- }
- };
-};
diff --git a/tests/support/flattened/Test-Assert.purs b/tests/support/flattened/Test-Assert.purs
deleted file mode 100644
index 66b8622..0000000
--- a/tests/support/flattened/Test-Assert.purs
+++ /dev/null
@@ -1,46 +0,0 @@
-module Test.Assert
- ( assert'
- , assert
- , assertThrows
- , assertThrows'
- , ASSERT()
- ) where
-
-import Control.Monad.Eff (Eff())
-import Prelude
-
--- | Assertion effect type.
-foreign import data ASSERT :: !
-
--- | Throws a runtime exception with message "Assertion failed" when the boolean
--- | value is false.
-assert :: forall e. Boolean -> Eff (assert :: ASSERT | e) Unit
-assert = assert' "Assertion failed"
-
--- | Throws a runtime exception with the specified message when the boolean
--- | value is false.
-foreign import assert' :: forall e. String -> Boolean -> Eff (assert :: ASSERT | e) Unit
-
--- | Throws a runtime exception with message "Assertion failed: An error should
--- | have been thrown", unless the argument throws an exception when evaluated.
--- |
--- | This function is specifically for testing unsafe pure code; for example,
--- | to make sure that an exception is thrown if a precondition is not
--- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be
--- | tested with `catchException` instead.
-assertThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Unit
-assertThrows = assertThrows' "Assertion failed: An error should have been thrown"
-
--- | Throws a runtime exception with the specified message, unless the argument
--- | throws an exception when evaluated.
--- |
--- | This function is specifically for testing unsafe pure code; for example,
--- | to make sure that an exception is thrown if a precondition is not
--- | satisfied. Functions which use `Eff (err :: EXCEPTION | eff) a` can be
--- | tested with `catchException` instead.
-assertThrows' :: forall e a. String -> (Unit -> a) -> Eff (assert :: ASSERT | e) Unit
-assertThrows' msg fn =
- checkThrows fn >>= assert' msg
-
-
-foreign import checkThrows :: forall e a. (Unit -> a) -> Eff (assert :: ASSERT | e) Boolean
diff --git a/tests/support/package.json b/tests/support/package.json
new file mode 100644
index 0000000..fa08203
--- /dev/null
+++ b/tests/support/package.json
@@ -0,0 +1,7 @@
+{
+ "private": true,
+ "dependencies": {
+ "bower": "^1.4.1",
+ "glob": "^5.0.14"
+ }
+}
diff --git a/tests/support/setup.js b/tests/support/setup.js
new file mode 100644
index 0000000..46b87b5
--- /dev/null
+++ b/tests/support/setup.js
@@ -0,0 +1,22 @@
+var glob = require("glob");
+var fs = require("fs");
+
+try {
+ fs.mkdirSync("./flattened");
+} catch(e) {
+ // ignore the error if it already exists
+ if (e.code !== "EEXIST") {
+ throw(e);
+ }
+}
+
+glob("bower_components/*/src/**/*.{js,purs}", function(err, files) {
+ if (err) throw err;
+ files.forEach(function(file) {
+ // We join with "-" because Cabal is weird about file extensions.
+ var dest = "./flattened/" + file.split("/").slice(3).join("-");
+ console.log("Copying " + file + " to " + dest);
+ var content = fs.readFileSync(file, "utf-8");
+ fs.writeFileSync(dest, content, "utf-8");
+ });
+})