summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-10-29 22:42:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-10-29 22:42:00 (GMT)
commit1b941c239d31605f6338b35e31ab5b1b7a991c70 (patch)
treec1afc321685c19b282657898bc8bb769f65cc85a
parent471ca956685a226af1c5c8734f340c50bf74051b (diff)
version 0.5.70.5.7
-rw-r--r--Setup.hs34
-rw-r--r--docgen/Main.hs14
-rw-r--r--examples/failing/DuplicateProperties1.purs9
-rw-r--r--examples/failing/DuplicateProperties2.purs9
-rw-r--r--examples/failing/Foldable.purs12
-rw-r--r--examples/failing/MissingClassExport.purs4
-rw-r--r--examples/failing/MissingClassMemberExport.purs4
-rw-r--r--examples/failing/OverlappingInstances.purs11
-rw-r--r--examples/failing/OverlappingInstances2.purs23
-rw-r--r--examples/passing/652.purs15
-rw-r--r--examples/passing/BindingGroups.purs8
-rw-r--r--examples/passing/EmptyRow.purs8
-rw-r--r--examples/passing/KindedType.purs31
-rw-r--r--psc-make/Main.hs6
-rw-r--r--psc/Main.hs6
-rw-r--r--psci/Main.hs37
-rw-r--r--purescript.cabal8
-rw-r--r--src/Language/PureScript.hs50
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs20
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs39
-rw-r--r--src/Language/PureScript/Declarations.hs6
-rw-r--r--src/Language/PureScript/Environment.hs6
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs4
-rw-r--r--src/Language/PureScript/Options.hs8
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs13
-rw-r--r--src/Language/PureScript/Parser/Types.hs14
-rw-r--r--src/Language/PureScript/Pretty/Types.hs9
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs74
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs2
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs20
-rw-r--r--src/Language/PureScript/TypeChecker.hs139
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs21
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs257
-rw-r--r--src/Language/PureScript/Types.hs61
34 files changed, 655 insertions, 327 deletions
diff --git a/Setup.hs b/Setup.hs
index 8f5b661..cd7b151 100644
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,38 +1,6 @@
-{-# LANGUAGE CPP #-}
-
-#ifndef POSIX_LIKE
-#define POSIX_LIKE !(defined(_WIN32_HOST_OS) || defined(_WIN64_HOST_OS)) && \
- (defined(unix_HOST_OS) || defined(__unix___HOST_OS) || \
- defined(__unix_HOST_OS) || defined(linux_HOST_OS) || \
- defined(__linux___HOST_OS) || defined(__linux_HOST_OS) || \
- (defined(__APPLE___HOST_OS) && defined(__MACH___HOST_OS)))
-#endif
-
module Main where
-import Control.Monad
-
-import Distribution.PackageDescription
import Distribution.Simple
-import Distribution.Simple.LocalBuildInfo
-import Distribution.Simple.Setup
-
-import System.Directory
-import System.Environment.XDG.BaseDir
-#if POSIX_LIKE
-import System.Posix.Files
-#endif
main :: IO ()
-main = defaultMainWithHooks $ simpleUserHooks {postInst = setupXDG}
-
-setupXDG :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ()
-setupXDG _ _ _ _ = do
- configDir <- getUserConfigDir "purescript"
- configExists <- doesDirectoryExist configDir
- unless configExists $ do
- createDirectoryIfMissing True configDir
-#if POSIX_LIKE
- setFileMode configDir ownerModes
-#endif
-#undef POSIX_LIKE
+main = defaultMain
diff --git a/docgen/Main.hs b/docgen/Main.hs
index d3d5ccb..d8c61db 100644
--- a/docgen/Main.hs
+++ b/docgen/Main.hs
@@ -141,7 +141,7 @@ renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =
atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do
let
- typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map P.TypeVar args)
+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
typeName = prettyPrintType' typeApp
exported = filter (isDctorExported name exps . fst) ctors
atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")
@@ -151,13 +151,17 @@ renderDeclaration n exps (P.DataDeclaration dtype name args ctors) = do
renderDeclaration n _ (P.ExternDataDeclaration name kind) =
atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
- let typeName = P.runProperName name ++ " " ++ unwords args
+ let
+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
+ typeName = prettyPrintType' typeApp
atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do
let impliesText = case implies of
[] -> ""
is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
- atIndent n $ "class " ++ impliesText ++ P.runProperName name ++ " " ++ unwords args ++ " where"
+ classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
+ className = prettyPrintType' classApp
+ atIndent n $ "class " ++ impliesText ++ className ++ " where"
mapM_ (renderDeclaration (n + 2) exps) ds
renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
let constraintsText = case constraints of
@@ -168,6 +172,10 @@ renderDeclaration n exps (P.PositionedDeclaration _ d) =
renderDeclaration n exps d
renderDeclaration _ _ _ = return ()
+toTypeVar :: (String, Maybe P.Kind) -> P.Type
+toTypeVar (s, Nothing) = P.TypeVar s
+toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
+
prettyPrintType' :: P.Type -> String
prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim
where
diff --git a/examples/failing/DuplicateProperties1.purs b/examples/failing/DuplicateProperties1.purs
new file mode 100644
index 0000000..1d7fbb8
--- /dev/null
+++ b/examples/failing/DuplicateProperties1.purs
@@ -0,0 +1,9 @@
+module DuplicateProperties where
+
+foreign import data Test :: # * -> *
+
+foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
+
+foreign import hasX "" :: Test (x :: Unit, y :: Unit)
+
+baz = subtractX (subtractX hasX)
diff --git a/examples/failing/DuplicateProperties2.purs b/examples/failing/DuplicateProperties2.purs
new file mode 100644
index 0000000..1b1f612
--- /dev/null
+++ b/examples/failing/DuplicateProperties2.purs
@@ -0,0 +1,9 @@
+module DuplicateProperties where
+
+foreign import data Test :: # * -> *
+
+foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
+
+foreign import hasX "" :: forall r. Test (x :: Unit, y :: Unit | r)
+
+baz = subtractX (subtractX hasX)
diff --git a/examples/failing/Foldable.purs b/examples/failing/Foldable.purs
new file mode 100644
index 0000000..abd73d9
--- /dev/null
+++ b/examples/failing/Foldable.purs
@@ -0,0 +1,12 @@
+module Main where
+
+class Foldable f where
+ fold :: forall a b. (a -> b -> b) -> b -> f a -> b
+ size :: forall a. f a -> Number
+
+instance foldableArray :: Foldable [] where
+ fold _ z [] = z
+ fold f z (x:xs) = x `f` (fold f z xs)
+ size = fold (const ((+) 1)) 0
+
+x = size [1,2,3]
diff --git a/examples/failing/MissingClassExport.purs b/examples/failing/MissingClassExport.purs
new file mode 100644
index 0000000..c1676fa
--- /dev/null
+++ b/examples/failing/MissingClassExport.purs
@@ -0,0 +1,4 @@
+module Test (bar) where
+
+ class Foo a where
+ bar :: a -> a
diff --git a/examples/failing/MissingClassMemberExport.purs b/examples/failing/MissingClassMemberExport.purs
new file mode 100644
index 0000000..9f8712e
--- /dev/null
+++ b/examples/failing/MissingClassMemberExport.purs
@@ -0,0 +1,4 @@
+module Test (Foo) where
+
+ class Foo a where
+ bar :: a -> a
diff --git a/examples/failing/OverlappingInstances.purs b/examples/failing/OverlappingInstances.purs
new file mode 100644
index 0000000..54e6b85
--- /dev/null
+++ b/examples/failing/OverlappingInstances.purs
@@ -0,0 +1,11 @@
+module OverlappingInstances where
+
+data A = A
+
+instance showA1 :: Show A where
+ show A = "Instance 1"
+
+instance showA2 :: Show A where
+ show A = "Instance 2"
+
+main = Debug.Trace.trace $ show A
diff --git a/examples/failing/OverlappingInstances2.purs b/examples/failing/OverlappingInstances2.purs
new file mode 100644
index 0000000..555b2ed
--- /dev/null
+++ b/examples/failing/OverlappingInstances2.purs
@@ -0,0 +1,23 @@
+module OverlappingInstances where
+
+data A = A | B
+
+instance eqA1 :: Eq A where
+ (==) A A = true
+ (==) B B = true
+ (==) _ _ = false
+ (/=) x y = not (x == y)
+
+instance eqA2 :: Eq A where
+ (==) _ _ = true
+ (/=) _ _ = false
+
+instance ordA :: Ord A where
+ compare A B = LT
+ compare B A = GT
+ compare _ _ = EQ
+
+test :: forall a. (Ord a) => a -> a -> String
+test x y = show $ x == y
+
+main = Debug.Trace.trace $ test A B
diff --git a/examples/passing/652.purs b/examples/passing/652.purs
new file mode 100644
index 0000000..4bfbc52
--- /dev/null
+++ b/examples/passing/652.purs
@@ -0,0 +1,15 @@
+module Main where
+
+class Foo a b
+
+class Bar a c
+
+class (Foo a b, Bar a c) <= Baz a b c
+
+instance foo :: Foo (a -> b) a
+
+instance bar :: Bar (a -> b) b
+
+instance baz :: (Eq a) => Baz (a -> b) a b
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/BindingGroups.purs b/examples/passing/BindingGroups.purs
new file mode 100644
index 0000000..e35da8a
--- /dev/null
+++ b/examples/passing/BindingGroups.purs
@@ -0,0 +1,8 @@
+module Main where
+
+foo = bar
+ where bar r = r + 1
+
+r = foo 2
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/EmptyRow.purs b/examples/passing/EmptyRow.purs
new file mode 100644
index 0000000..c91c930
--- /dev/null
+++ b/examples/passing/EmptyRow.purs
@@ -0,0 +1,8 @@
+module Main where
+
+data Foo r = Foo { | r }
+
+test :: Foo ()
+test = Foo {}
+
+main = Debug.Trace.trace "Done"
diff --git a/examples/passing/KindedType.purs b/examples/passing/KindedType.purs
new file mode 100644
index 0000000..5e09b5b
--- /dev/null
+++ b/examples/passing/KindedType.purs
@@ -0,0 +1,31 @@
+module Main where
+
+type Star2Star f = f :: * -> *
+
+type Star t = t :: *
+
+test1 :: Star2Star [] String
+test1 = ["test"]
+
+f :: Star (String -> String)
+f s = s
+
+test2 = f "test"
+
+data Proxy (f :: * -> *) = Proxy
+
+test3 :: Proxy []
+test3 = Proxy
+
+type Test (f :: * -> *) = f String
+
+test4 :: Test []
+test4 = ["test"]
+
+class Clazz (a :: *) where
+ def :: a
+
+instance clazzString :: Clazz String where
+ def = "test"
+
+main = Debug.Trace.trace "Done"
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index 14d5f86..1f00e69 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -104,10 +104,6 @@ noTco :: Term Bool
noTco = value $ flag $ (optInfo [ "no-tco" ])
{ optDoc = "Disable tail call optimizations" }
-performRuntimeTypeChecks :: Term Bool
-performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
- { optDoc = "Generate runtime type checks" }
-
noPrelude :: Term Bool
noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
{ optDoc = "Omit the Prelude" }
@@ -125,7 +121,7 @@ verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
{ optDoc = "Display verbose error messages" }
options :: Term (P.Options P.Make)
-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> verboseErrors <*> pure P.MakeOptions
+options = P.Options <$> noPrelude <*> noTco <*> noMagicDo <*> pure Nothing <*> noOpts <*> verboseErrors <*> pure P.MakeOptions
noPrefix :: Term Bool
noPrefix = value $ flag $ (optInfo ["p", "no-prefix" ])
diff --git a/psc/Main.hs b/psc/Main.hs
index 5e10ceb..a272ba9 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -96,10 +96,6 @@ noTco :: Term Bool
noTco = value $ flag $ (optInfo [ "no-tco" ])
{ optDoc = "Disable tail call optimizations" }
-performRuntimeTypeChecks :: Term Bool
-performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
- { optDoc = "Generate runtime type checks" }
-
noPrelude :: Term Bool
noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
{ optDoc = "Omit the Prelude" }
@@ -137,7 +133,7 @@ noPrefix = value $ flag $ (optInfo ["no-prefix" ])
{ optDoc = "Do not include comment header"}
options :: Term (P.Options P.Compile)
-options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> verboseErrors <*> additionalOptions
+options = P.Options <$> noPrelude <*> noTco <*> noMagicDo <*> runMain <*> noOpts <*> verboseErrors <*> additionalOptions
where
additionalOptions = P.CompileOptions <$> browserNamespace <*> dceModules <*> codeGenModules
diff --git a/psci/Main.hs b/psci/Main.hs
index 1a6513b..e498c99 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -43,7 +43,6 @@ import System.Directory
findExecutable, getHomeDirectory, getCurrentDirectory)
import System.Process (readProcessWithExitCode)
import System.Exit
-import System.Environment.XDG.BaseDir
import System.FilePath
(pathSeparator, takeDirectory, (</>), isPathSeparator)
import qualified System.Console.CmdTheLine as Cmd
@@ -114,7 +113,11 @@ findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
-- Grabs the filename where the history is stored.
--
getHistoryFilename :: IO FilePath
-getHistoryFilename = getUserConfigFile "purescript" "psci_history"
+getHistoryFilename = do
+ home <- getHomeDirectory
+ let filename = home </> ".purescript" </> "psci_history"
+ mkdirp filename
+ return filename
-- |
-- Loads a file for use with imports.
@@ -199,7 +202,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions
-- | Compilation options.
--
options :: P.Options P.Make
-options = P.Options False False False False Nothing False False P.MakeOptions
+options = P.Options False False False Nothing False False P.MakeOptions
-- |
-- PSCI monad
@@ -263,6 +266,17 @@ createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =
in
P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
+-- |
+-- Makes a volatile module to execute the current imports.
+--
+createTemporaryModuleForImports :: PSCiState -> P.Module
+createTemporaryModuleForImports PSCiState{psciImportedModuleNames = imports} =
+ let
+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing
+ in
+ P.Module moduleName (importDecl `map` imports) Nothing
+
modulesDir :: FilePath
modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
@@ -289,6 +303,20 @@ handleDeclaration value = do
Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
-- |
+-- Imports a module, preserving the initial state on failure.
+--
+handleImport :: P.ModuleName -> PSCI ()
+handleImport moduleName = do
+ s <- liftM (updateImports moduleName) $ PSCI $ lift get
+ let m = createTemporaryModuleForImports s
+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules s ++ [("$PSCI.purs", m)]) []
+ case e of
+ Left err -> PSCI $ outputStrLn err
+ Right _ -> do
+ PSCI $ lift $ put s
+ return ()
+
+-- |
-- Takes a value and prints its type
--
handleTypeOf :: P.Expr -> PSCI ()
@@ -347,7 +375,7 @@ getCommand singleLineMode = do
handleCommand :: Command -> PSCI ()
handleCommand (Expression val) = handleDeclaration val
handleCommand Help = PSCI $ outputStrLn helpMessage
-handleCommand (Import moduleName) = PSCI $ lift $ modify (updateImports moduleName)
+handleCommand (Import moduleName) = handleImport moduleName
handleCommand (Let l) = PSCI $ lift $ modify (updateLets l)
handleCommand (LoadFile filePath) = do
absPath <- psciIO $ expandTilde filePath
@@ -435,4 +463,3 @@ termInfo = Cmd.defTI
main :: IO ()
main = Cmd.run (term, termInfo)
-
diff --git a/purescript.cabal b/purescript.cabal
index 8fb3219..70d63de 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,7 +1,7 @@
name: purescript
-version: 0.5.6.3
+version: 0.5.7
cabal-version: >=1.8
-build-type: Custom
+build-type: Simple
license: MIT
license-file: LICENSE
copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
@@ -30,7 +30,7 @@ library
transformers >= 0.3 && < 0.5, utf8-string -any,
pattern-arrows >= 0.0.2 && < 0.1,
monad-unify >= 0.2.2 && < 0.3,
- xdg-basedir -any, time -any
+ time -any
if (!os(windows))
build-depends: unix -any
exposed-modules: Language.PureScript
@@ -115,7 +115,7 @@ executable psci
build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
mtl -any, parsec -any, haskeline >= 0.7.0.0, purescript -any,
transformers -any, utf8-string -any, process -any,
- xdg-basedir -any, cmdtheline -any
+ cmdtheline -any
main-is: Main.hs
buildable: True
hs-source-dirs: psci
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 678b813..f4cc5dd 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -38,12 +38,11 @@ import Language.PureScript.Renamer as P
import qualified Language.PureScript.Constants as C
import qualified Paths_purescript as Paths
-import Data.List (find, sortBy, groupBy, intercalate)
+import Data.List (sortBy, groupBy, intercalate)
import Data.Time.Clock
import Data.Function (on)
import Data.Maybe (listToMaybe, fromMaybe)
import Control.Monad.Error
-import Control.Monad.State.Lazy
import Control.Arrow ((&&&))
import Control.Applicative
import qualified Data.Map as M
@@ -51,7 +50,6 @@ import qualified Data.Set as S
import System.FilePath ((</>), pathSeparator)
import System.Directory (getHomeDirectory, doesFileExist)
-import System.Environment.XDG.BaseDir (getUserConfigDir)
-- |
-- Compile a collection of modules
@@ -94,43 +92,6 @@ compile' env opts ms prefix = do
where
mainModuleIdent = moduleNameFromString <$> optionsMain opts
-typeCheckModule :: Maybe ModuleName -> Module -> Check Module
-typeCheckModule mainModuleName (Module mn decls exps) = do
- modify (\s -> s { checkCurrentModule = Just mn })
- decls' <- typeCheckAll mainModuleName mn exps decls
- mapM_ checkTypesAreExported exps'
- return $ Module mn decls' exps
- where
-
- exps' = fromMaybe (error "exports should have been elaborated") exps
-
- -- Check that all the type constructors defined in the current module that appear in member types
- -- have also been exported from the module
- checkTypesAreExported :: DeclarationRef -> Check ()
- checkTypesAreExported (ValueRef name) = do
- ty <- lookupVariable mn (Qualified (Just mn) name)
- case find isTconHidden (findTcons ty) of
- Just hiddenType -> throwError . strMsg $
- "Error in module '" ++ show mn ++ "':\n\
- \Exporting declaration '" ++ show name ++ "' requires type '" ++ show hiddenType ++ "' to be exported as well"
- Nothing -> return ()
- checkTypesAreExported _ = return ()
-
- -- Find the type constructors exported from the current module used in a type
- findTcons :: Type -> [ProperName]
- findTcons = everythingOnTypes (++) go
- where
- go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
- go _ = []
-
- -- Checks whether a type constructor is not being exported from the current module
- isTconHidden :: ProperName -> Bool
- isTconHidden tyName = all go exps'
- where
- go (TypeRef tyName' _) = tyName' /= tyName
- go _ = True
-
-
generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]
generateMain env opts js =
case moduleNameFromString <$> optionsMain opts of
@@ -272,16 +233,11 @@ importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
preludeFilename :: IO FilePath
preludeFilename = fromMaybe missingPrelude . listToMaybe <$> do
- fs <- sequence [xdsPrelude, homePrelude, cabalPrelude]
+ fs <- sequence [homePrelude, cabalPrelude]
filterM doesFileExist fs
where
missingPrelude :: FilePath
- missingPrelude = error "No Prelude found in user home, XDS user config directory or cabal path."
-
- xdsPrelude :: IO FilePath
- xdsPrelude = do
- configDir <- getUserConfigDir "purescript"
- return $ configDir </> "prelude" </> "prelude.purs"
+ missingPrelude = error "No Prelude found in user home or cabal path."
homePrelude :: IO FilePath
homePrelude = do
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index c8ede82..76b49c7 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -29,6 +29,8 @@ import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Declarations
import Language.PureScript.Pretty
import Language.PureScript.Names
+import Language.PureScript.Kinds
+import Language.PureScript.Types
import Language.PureScript.Environment
-- |
@@ -64,12 +66,15 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')
then "newtype"
else "data"
- tell [dtype ++ " " ++ show pn ++ " " ++ unwords args ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
+ tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
Just (_, TypeSynonym) ->
case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
Just (args, synTy) ->
- tell ["type " ++ show pn ++ " " ++ unwords args ++ " = " ++ prettyPrintType synTy]
+ let
+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
+ in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]
_ -> error "Invalid input in exportToPs"
exportToPs (ValueRef ident) =
@@ -82,8 +87,11 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
case Qualified (Just moduleName) className `M.lookup` typeClasses env of
Nothing -> error $ show className ++ " has no type class definition in exportToPs"
Just (args, members, implies) -> do
- let impliesString = if null implies then "" else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
- tell ["class " ++ impliesString ++ show className ++ " " ++ unwords args ++ " where"]
+ let impliesString = if null implies
+ then ""
+ else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)
+ tell ["class " ++ impliesString ++ typeName ++ " where"]
forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
@@ -95,6 +103,10 @@ moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWrite
cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
+ toTypeVar :: (String, Maybe Kind) -> Type
+ toTypeVar (s, Nothing) = TypeVar s
+ toTypeVar (s, Just k) = KindedType (TypeVar s) k
+
isValueExported :: Ident -> Bool
isValueExported ident = ValueRef ident `elem` exts
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index f08ef43..9fead75 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -33,7 +33,6 @@ import Language.PureScript.Names
import Language.PureScript.Declarations
import Language.PureScript.Options
import Language.PureScript.CodeGen.JS.AST as AST
-import Language.PureScript.Types
import Language.PureScript.Optimizer
import Language.PureScript.CodeGen.Common
import Language.PureScript.Environment
@@ -95,7 +94,7 @@ declToJs opts mp (ValueDeclaration ident _ _ _ val) e = do
js <- valueToJs opts mp e val
return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
declToJs opts mp (BindingGroupDeclaration vals) e = do
- jss <- flip mapM vals $ \(ident, _, val) -> do
+ jss <- forM vals $ \(ident, _, val) -> do
js <- valueToJs opts mp e val
return $ JSVariableIntroduction (identToJs ident) (Just js)
return $ Just jss
@@ -228,10 +227,6 @@ valueToJs opts m e (Let ds val) = do
valueToJs opts m e (Abs (Left arg) val) = do
ret <- valueToJs opts m e val
return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
-valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = do
- let arg' = identToJs arg
- ret <- valueToJs opts m e val
- return $ JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn ret])
valueToJs _ m _ (Var ident) = return $ varToJs m ident
valueToJs opts m e (TypedValue _ val _) = valueToJs opts m e val
valueToJs opts m e (PositionedValue _ val) = valueToJs opts m e val
@@ -258,38 +253,6 @@ extendObj obj sts = do
return $ JSApp (JSFunction Nothing [] block) []
-- |
--- Generate code in the simplified Javascript intermediate representation for runtime type checks.
---
-runtimeTypeChecks :: String -> Type -> [JS]
-runtimeTypeChecks arg ty =
- let
- argTy = getFunctionArgumentType ty
- in
- maybe [] (argumentCheck (JSVar arg)) argTy
- where
- getFunctionArgumentType :: Type -> Maybe Type
- getFunctionArgumentType (TypeApp (TypeApp t funArg) _) | t == tyFunction = Just funArg
- getFunctionArgumentType (ForAll _ ty' _) = getFunctionArgumentType ty'
- getFunctionArgumentType _ = Nothing
- argumentCheck :: JS -> Type -> [JS]
- argumentCheck val t | t == tyNumber = [typeCheck val "number"]
- argumentCheck val t | t == tyString = [typeCheck val "string"]
- argumentCheck val t | t == tyBoolean = [typeCheck val "boolean"]
- argumentCheck val (TypeApp t _) | t == tyArray = [arrayCheck val]
- argumentCheck val (TypeApp t row) | t == tyObject =
- let
- (pairs, _) = rowToList row
- in
- typeCheck val "object" : concatMap (\(prop, ty') -> argumentCheck (accessorString prop val) ty') pairs
- argumentCheck val (TypeApp (TypeApp t _) _) | t == tyFunction = [typeCheck val "function"]
- argumentCheck val (ForAll _ ty' _) = argumentCheck val ty'
- argumentCheck _ _ = []
- typeCheck :: JS -> String -> JS
- typeCheck js ty' = JSIfElse (JSBinary NotEqualTo (JSTypeOf js) (JSStringLiteral ty')) (JSBlock [JSThrow (JSStringLiteral $ ty' ++ " expected")]) Nothing
- arrayCheck :: JS -> JS
- arrayCheck js = JSIfElse (JSUnary Not (JSApp (JSAccessor "isArray" (JSVar "Array")) [js])) (JSBlock [JSThrow (JSStringLiteral "Array expected")]) Nothing
-
--- |
-- Generate code in the simplified Javascript intermediate representation for a reference to a
-- variable.
--
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index a3b7689..e21567b 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -138,7 +138,7 @@ data Declaration
-- |
-- A data type declaration (data or newtype, name, arguments, data constructors)
--
- = DataDeclaration DataDeclType ProperName [String] [(ProperName, [Type])]
+ = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
-- |
-- A minimal mutually recursive set of data type declarations
--
@@ -146,7 +146,7 @@ data Declaration
-- |
-- A type synonym declaration (name, arguments, type)
--
- | TypeSynonymDeclaration ProperName [String] Type
+ | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
-- |
-- A type declaration for a value (name, ty)
--
@@ -183,7 +183,7 @@ data Declaration
-- |
-- A type class declaration (name, argument, implies, member declarations)
--
- | TypeClassDeclaration ProperName [String] [(Qualified ProperName, [Type])] [Declaration]
+ | TypeClassDeclaration ProperName [(String, Maybe Kind)] [(Qualified ProperName, [Type])] [Declaration]
-- |
-- A type instance declaration (name, dependencies, class name, instance types, member
-- declarations)
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 6eef096..c65999f 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -45,7 +45,7 @@ data Environment = Environment {
-- |
-- Type synonyms currently in scope
--
- , typeSynonyms :: M.Map (Qualified ProperName) ([String], Type)
+ , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)
-- |
-- Available type class dictionaries
--
@@ -53,7 +53,7 @@ data Environment = Environment {
-- |
-- Type classes
--
- , typeClasses :: M.Map (Qualified ProperName) ([String], [(Ident, Type)], [(Qualified ProperName, [Type])])
+ , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [(Qualified ProperName, [Type])])
} deriving (Show)
-- |
@@ -124,7 +124,7 @@ data TypeKind
-- |
-- Data type
--
- = DataType [String] [(ProperName, [Type])]
+ = DataType [(String, Maybe Kind)] [(ProperName, [Type])]
-- |
-- Type synonym
--
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
index df817f7..d09e74b 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -99,8 +99,8 @@ magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'
isEffFunc _ _ = False
-- Check if an expression represents the Monad Eff dictionary
- isEffDict name (JSApp (JSVar ident) []) | ident == name = True
- isEffDict name (JSApp (JSAccessor prop (JSVar eff)) []) = eff == C.eff && prop == name
+ isEffDict name (JSVar ident) | ident == name = True
+ isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name
isEffDict _ _ = False
-- Remove __do function applications which remain after desugaring
undo :: JS -> JS
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 6ffa3df..421ab1f 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -53,10 +53,6 @@ data Options mode = Options {
--
, optionsNoTco :: Bool
-- |
- -- Perform type checks at runtime
- --
- , optionsPerformRuntimeTypeChecks :: Bool
- -- |
-- Disable inlining of calls to return and bind for the Eff monad
--
, optionsNoMagicDo :: Bool
@@ -84,10 +80,10 @@ data Options mode = Options {
-- Default compiler options
--
defaultCompileOptions :: Options Compile
-defaultCompileOptions = Options False False False False Nothing False False (CompileOptions "PS" [] [])
+defaultCompileOptions = Options False False False Nothing False False (CompileOptions "PS" [] [])
-- |
-- Default make options
--
defaultMakeOptions :: Options Make
-defaultMakeOptions = Options False False False False Nothing False False MakeOptions
+defaultMakeOptions = Options False False False Nothing False False MakeOptions
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 49fabec..db9fee6 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -13,6 +13,8 @@
--
-----------------------------------------------------------------------------
+{-# LANGUAGE TupleSections #-}
+
module Language.PureScript.Parser.Declarations (
parseDeclaration,
parseModule,
@@ -28,6 +30,7 @@ import Data.Maybe (isJust, fromMaybe)
import Control.Applicative
import Control.Arrow ((+++))
+import Language.PureScript.Kinds
import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
import Language.PureScript.Declarations
@@ -48,11 +51,15 @@ sourcePos = toSourcePos <$> P.getPosition
where
toSourcePos p = SourcePos (P.sourceName p) (P.sourceLine p) (P.sourceColumn p)
+kindedIdent :: P.Parsec String ParseState (String, Maybe Kind)
+kindedIdent = (, Nothing) <$> identifier
+ <|> parens ((,) <$> identifier <*> (Just <$> (indented *> lexeme (P.string "::") *> indented *> parseKind)))
+
parseDataDeclaration :: P.Parsec String ParseState Declaration
parseDataDeclaration = do
dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
name <- indented *> properName
- tyArgs <- many (indented *> identifier)
+ tyArgs <- many (indented *> kindedIdent)
ctors <- P.option [] $ do
_ <- lexeme $ indented *> P.char '='
sepBy1 ((,) <$> properName <*> P.many (indented *> parseTypeAtom)) pipe
@@ -66,7 +73,7 @@ parseTypeDeclaration =
parseTypeSynonymDeclaration :: P.Parsec String ParseState Declaration
parseTypeSynonymDeclaration =
TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
- <*> many (indented *> identifier)
+ <*> many (indented *> kindedIdent)
<*> (lexeme (indented *> P.char '=') *> parsePolyType)
parseValueDeclaration :: P.Parsec String ParseState Declaration
@@ -163,7 +170,7 @@ parseTypeClassDeclaration = do
reservedOp "<="
return implies
className <- indented *> properName
- idents <- P.many (indented *> identifier)
+ idents <- P.many (indented *> kindedIdent)
members <- P.option [] . P.try $ do
indented *> reserved "where"
mark (P.many (same *> positioned parseTypeDeclaration))
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index c5d2d21..413ae90 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -25,6 +25,7 @@ import Control.Monad (when, unless)
import Language.PureScript.Types
import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
+import Language.PureScript.Parser.Kinds
import Language.PureScript.Environment
import qualified Text.Parsec as P
@@ -40,7 +41,7 @@ parseFunction :: P.Parsec String ParseState Type
parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction
parseObject :: P.Parsec String ParseState Type
-parseObject = braces $ TypeApp tyObject <$> parseRow False
+parseObject = braces $ TypeApp tyObject <$> parseRow
parseTypeVariable :: P.Parsec String ParseState Type
parseTypeVariable = do
@@ -67,7 +68,7 @@ parseTypeAtom = indented *> P.choice (map P.try
, parseTypeVariable
, parseTypeConstructor
, parseForAll
- , parens (parseRow True)
+ , parens parseRow
, parens parsePolyType ])
parseConstrainedType :: P.Parsec String ParseState Type
@@ -85,10 +86,12 @@ parseConstrainedType = do
return $ maybe ty (flip ConstrainedType ty) constraints
parseAnyType :: P.Parsec String ParseState Type
-parseAnyType = P.buildExpressionParser operators parseTypeAtom P.<?> "type"
+parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
where
operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
, [ P.Infix (P.try (lexeme (P.string "->")) >> return function) P.AssocRight ] ]
+ postfixTable = [ \t -> KindedType t <$> (P.try (lexeme (indented *> P.string "::")) *> parseKind)
+ ]
-- |
-- Parse a monotype
@@ -111,6 +114,5 @@ parseNameAndType p = (,) <$> (indented *> (identifier <|> stringLiteral) <* inde
parseRowEnding :: P.Parsec String ParseState Type
parseRowEnding = P.option REmpty (TypeVar <$> (lexeme (indented *> P.char '|') *> indented *> identifier))
-parseRow :: Bool -> P.Parsec String ParseState Type
-parseRow nonEmpty = (curry rowFromList <$> many' (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
- where many' = if nonEmpty then commaSep1 else commaSep
+parseRow :: P.Parsec String ParseState Type
+parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index b044cf5..d4681b3 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -26,7 +26,9 @@ import Control.Arrow ((<+>))
import Control.PatternArrows
import Language.PureScript.Types
+import Language.PureScript.Kinds
import Language.PureScript.Pretty.Common
+import Language.PureScript.Pretty.Kinds
import Language.PureScript.Environment
typeLiterals :: Pattern () Type String
@@ -71,6 +73,12 @@ appliedFunction = mkPattern match
match (PrettyPrintFunction arg ret) = Just (arg, ret)
match _ = Nothing
+kinded :: Pattern () Type (Kind, Type)
+kinded = mkPattern match
+ where
+ match (KindedType t k) = Just (k, t)
+ match _ = Nothing
+
insertPlaceholders :: Type -> Type
insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert
where
@@ -96,6 +104,7 @@ matchType = buildPrettyPrinter operators matchTypeAtom
, [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret
]
, [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]
+ , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ]
]
forall_ :: Pattern () Type ([String], Type)
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index 011dce1..c9d6f5c 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -24,8 +24,11 @@ module Language.PureScript.Sugar.BindingGroups (
import Data.Graph
import Data.List (nub, intersect)
import Data.Maybe (isJust, mapMaybe)
+import Data.Monoid ((<>))
import Control.Applicative ((<$>), (<*>), pure)
+import qualified Data.Set as S
+
import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
@@ -56,7 +59,7 @@ createBindingGroups moduleName ds = do
dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts
let allIdents = map getIdent values
valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
- bindingGroupDecls = map toBindingGroup $ stronglyConnComp valueVerts
+ bindingGroupDecls <- mapM (toBindingGroup moduleName) $ stronglyConnComp valueVerts
return $ filter isImportDecl ds ++
filter isExternDataDecl ds ++
filter isExternInstanceDecl ds ++
@@ -91,13 +94,32 @@ collapseBindingGroupsForValue other = other
usedIdents :: ModuleName -> Declaration -> [Ident]
usedIdents moduleName =
- let (f, _, _, _, _) = everythingOnValues (++) (const []) usedNames (const []) (const []) (const [])
+ let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def
in nub . f
where
- usedNames :: Expr -> [Ident]
- usedNames (Var (Qualified Nothing name)) = [name]
- usedNames (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
- usedNames _ = []
+ def s _ = (s, [])
+
+ usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])
+ usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])
+ usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])
+ usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])
+ usedNamesE scope _ = (scope, [])
+
+ usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])
+ usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])
+
+usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
+usedImmediateIdents moduleName =
+ let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def
+ in nub . f
+ where
+ def s _ = (s, [])
+
+ usedNamesE :: Bool -> Expr -> (Bool, [Ident])
+ usedNamesE True (Var (Qualified Nothing name)) = (True, [name])
+ usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])
+ usedNamesE True (Abs _ _) = (False, [])
+ usedNamesE scope _ = (scope, [])
usedProperNames :: ModuleName -> Declaration -> [ProperName]
usedProperNames moduleName =
@@ -123,10 +145,42 @@ getProperName (TypeSynonymDeclaration pn _ _) = pn
getProperName (PositionedDeclaration _ d) = getProperName d
getProperName _ = error "Expected DataDeclaration"
-toBindingGroup :: SCC Declaration -> Declaration
-toBindingGroup (AcyclicSCC d) = d
-toBindingGroup (CyclicSCC [d]) = d
-toBindingGroup (CyclicSCC ds') = BindingGroupDeclaration $ map fromValueDecl ds'
+-- |
+-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
+--
+--
+toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration
+toBindingGroup _ (AcyclicSCC d) = return d
+toBindingGroup _ (CyclicSCC [d]) = return d
+toBindingGroup moduleName (CyclicSCC ds') =
+ -- Once we have a mutually-recursive group of declarations, we need to sort
+ -- them further by their immediate dependencies (those outside function
+ -- bodies). In particular, this is relevant for type instance dictionaries
+ -- whose members require other type instances (for example, functorEff
+ -- defines (<$>) = liftA1, which depends on applicativeEff). Note that
+ -- superclass references are still inside functions, so don't count here.
+ -- If we discover declarations that still contain mutually-recursive
+ -- immediate references, we're guaranteed to get an undefined reference at
+ -- runtime, so treat this as an error. See also github issue #365.
+ BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts)
+ where
+ idents :: [Ident]
+ idents = map (\(_, i, _) -> i) valueVerts
+
+ valueVerts :: [(Declaration, Ident, [Ident])]
+ valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
+
+ toBinding :: SCC Declaration -> Either ErrorStack (Ident, NameKind, Expr)
+ toBinding (AcyclicSCC d) = return $ fromValueDecl d
+ toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
+
+ cycleError :: Declaration -> [Declaration] -> Either ErrorStack a
+ cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds
+ cycleError (ValueDeclaration n _ _ _ e) [] = Left $
+ mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))
+ cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []
+ cycleError _ _ = error "Expected ValueDeclaration"
+
toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration
toDataBindingGroup (AcyclicSCC d) = return d
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index d41e621..72178be 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -91,7 +91,7 @@ toDecls ds@(ValueDeclaration ident _ bs g _ : _) = do
unless (all ((== length bs) . length . fst) tuples) $
throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
unless (not (null bs) || isJust g) $
- throwError $ mkErrorStack ("Top level case disallowed in declaration " ++ show ident) Nothing
+ throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing
caseDecl <- makeCaseDeclaration ident tuples
return [caseDecl]
toDecls (PositionedDeclaration pos d : ds) = do
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index fa46877..697cff6 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -21,6 +21,7 @@ module Language.PureScript.Sugar.TypeClasses (
import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
+import Language.PureScript.Kinds
import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Environment
import Language.PureScript.Errors
@@ -197,7 +198,7 @@ memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
memberToNameAndType _ = error "Invalid declaration in type class definition"
-typeClassDictionaryDeclaration :: ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration
+typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Declaration
typeClassDictionaryDeclaration name args implies members =
let superclassTypes = [ (fieldName, function unit tySynApp)
| (index, (superclass, tyArgs)) <- zip [0..] implies
@@ -208,11 +209,11 @@ typeClassDictionaryDeclaration name args implies members =
mtys = members' ++ superclassTypes
in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
-typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
+typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
ValueDeclaration ident TypeClassAccessorImport [] Nothing $
TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
- moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map TypeVar args)] ty))
+ moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))
typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
@@ -240,27 +241,24 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
let instanceTys = map memberToNameAndType tyDecls
-- Replace the type arguments with the appropriate types in the member types
- let memberTypes = map (second (replaceAllTypeVars (zip args tys))) instanceTys
+ let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
-- Create values for the type instance members
memberNames <- map (first runIdent) <$> mapM (memberToNameAndValue memberTypes) decls
-- Create the type of the dictionary
-- The type is an object type, but depending on type instance dependencies, may be constrained.
- -- The dictionary itself is an object literal, but for reasons related to recursion, the dictionary
- -- must be guarded by at least one function abstraction. For that reason, if the dictionary has no
- -- dependencies, we introduce an unnamed function parameter.
+ -- The dictionary itself is an object literal.
let superclasses =
[ (fieldName, Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs))
| (index, (superclass, suTyArgs)) <- zip [0..] implies
- , let tyArgs = map (replaceAllTypeVars (zip args tys)) suTyArgs
+ , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
, let fieldName = mkSuperclassDictionaryName superclass index
]
let memberNames' = ObjectLiteral (memberNames ++ superclasses)
dictTy = foldl TypeApp (TypeConstructor className) tys
- constrainedTy = quantify (if null deps then function unit dictTy else ConstrainedType deps dictTy)
+ constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
dict = TypeClassDictionaryConstructorApp className memberNames'
- dict' = if null deps then Abs (Left (Ident C.__unused)) dict else dict
- result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict' constrainedTy)
+ result = ValueDeclaration name TypeInstanceDictionaryValue [] Nothing (TypedValue True dict constrainedTy)
return result
where
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index a5c0ec7..6bedf85 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -17,7 +17,7 @@
module Language.PureScript.TypeChecker (
module T,
- typeCheckAll
+ typeCheckModule
) where
import Language.PureScript.TypeChecker.Monad as T
@@ -26,7 +26,7 @@ import Language.PureScript.TypeChecker.Types as T
import Language.PureScript.TypeChecker.Synonyms as T
import Data.Maybe
-import Data.List (nub, (\\))
+import Data.List (nub, (\\), find, intercalate)
import Data.Monoid ((<>))
import Data.Foldable (for_)
import qualified Data.Map as M
@@ -42,13 +42,13 @@ import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Environment
import Language.PureScript.Errors
-addDataType :: ModuleName -> DataDeclType -> ProperName -> [String] -> [(ProperName, [Type])] -> Kind -> Check ()
+addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check ()
addDataType moduleName dtype name args dctors ctorKind = do
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
forM_ dctors $ \(dctor, tys) ->
rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
- addDataConstructor moduleName dtype name args dctor tys
+ addDataConstructor moduleName dtype name (map fst args) dctor tys
addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
addDataConstructor moduleName dtype name args dctor tys = do
@@ -58,7 +58,7 @@ addDataConstructor moduleName dtype name args dctor tys = do
let polyType = mkForAll args dctorTy
putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (dataConstructors env) }
-addTypeSynonym :: ModuleName -> ProperName -> [String] -> Type -> Kind -> Check ()
+addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
addTypeSynonym moduleName name args ty kind = do
env <- getEnv
putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
@@ -76,7 +76,7 @@ addValue moduleName name ty nameKind = do
env <- getEnv
putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
-addTypeClass :: ModuleName -> ProperName -> [String] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
+addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [(Qualified ProperName, [Type])] -> [Declaration] -> Check ()
addTypeClass moduleName pn args implies ds =
let members = map toPair ds in
modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
@@ -119,19 +119,20 @@ checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance hea
--
-- * Process module imports
--
-typeCheckAll :: Maybe ModuleName -> ModuleName -> Maybe [DeclarationRef] -> [Declaration] -> Check [Declaration]
+typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
typeCheckAll mainModuleName moduleName exps = go
where
go :: [Declaration] -> Check [Declaration]
go [] = return []
- go (d@(DataDeclaration dtype name args dctors) : rest) = do
+ go (DataDeclaration dtype name args dctors : rest) = do
rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
when (dtype == Newtype) $ checkNewtype dctors
- checkDuplicateTypeArguments args
+ checkDuplicateTypeArguments $ map fst args
ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
- addDataType moduleName dtype name args dctors ctorKind
+ let args' = args `withKinds` ctorKind
+ addDataType moduleName dtype name args' dctors ctorKind
ds <- go rest
- return $ d : ds
+ return $ DataDeclaration dtype name args dctors : ds
where
checkNewtype :: [(ProperName, [Type])] -> Check ()
checkNewtype [(_, [_])] = return ()
@@ -143,11 +144,13 @@ typeCheckAll mainModuleName moduleName exps = go
let dataDecls = mapMaybe toDataDecl tys
(syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
- checkDuplicateTypeArguments args
- addDataType moduleName dtype name args dctors ctorKind
+ checkDuplicateTypeArguments $ map fst args
+ let args' = args `withKinds` ctorKind
+ addDataType moduleName dtype name args' dctors ctorKind
forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
- checkDuplicateTypeArguments args
- addTypeSynonym moduleName name args ty kind
+ checkDuplicateTypeArguments $ map fst args
+ let args' = args `withKinds` kind
+ addTypeSynonym moduleName name args' ty kind
ds <- go rest
return $ d : ds
where
@@ -157,13 +160,14 @@ typeCheckAll mainModuleName moduleName exps = go
toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
toDataDecl (PositionedDeclaration _ d') = toDataDecl d'
toDataDecl _ = Nothing
- go (d@(TypeSynonymDeclaration name args ty) : rest) = do
+ go (TypeSynonymDeclaration name args ty : rest) = do
rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
- checkDuplicateTypeArguments args
+ checkDuplicateTypeArguments $ map fst args
kind <- kindsOf False moduleName name args [ty]
- addTypeSynonym moduleName name args ty kind
+ let args' = args `withKinds` kind
+ addTypeSynonym moduleName name args' ty kind
ds <- go rest
- return $ d : ds
+ return $ TypeSynonymDeclaration name args ty : ds
go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
go (ValueDeclaration name nameKind [] Nothing val : rest) = do
d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
@@ -219,7 +223,7 @@ typeCheckAll mainModuleName moduleName exps = go
addTypeClass moduleName pn args implies tys
ds <- go rest
return $ d : ds
- go (TypeInstanceDeclaration dictName deps className tys _ : rest) = do
+ go (TypeInstanceDeclaration dictName deps className tys _ : rest) =
go (ExternInstanceDeclaration dictName deps className tys : rest)
go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
mapM_ (checkTypeClassInstance moduleName) tys
@@ -229,18 +233,107 @@ typeCheckAll mainModuleName moduleName exps = go
return $ d : ds
where
isInstanceExported :: Bool
- isInstanceExported = maybe True (any exportsInstance) exps
-
+ isInstanceExported = any exportsInstance exps
+
exportsInstance :: DeclarationRef -> Bool
exportsInstance (TypeInstanceRef name) | name == dictName = True
exportsInstance (PositionedDeclarationRef _ r) = exportsInstance r
exportsInstance _ = False
-
+
go (PositionedDeclaration pos d : rest) =
rethrowWithPosition pos $ do
(d' : rest') <- go (d : rest)
return (PositionedDeclaration pos d' : rest')
+
+ -- |
+ -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
+ -- extracted from the kind of the type constructor itself.
+ --
+ withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
+ withKinds [] _ = []
+ withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
+ withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
+ withKinds _ _ = error "Invalid arguments to peelKinds"
+-- |
+-- Type check an entire module and ensure all types and classes defined within the module that are
+-- required by exported members are also exported.
+--
+typeCheckModule :: Maybe ModuleName -> Module -> Check Module
+typeCheckModule _ (Module _ _ Nothing) = error "exports should have been elaborated"
+typeCheckModule mainModuleName (Module mn decls (Just exps)) = do
+ modify (\s -> s { checkCurrentModule = Just mn })
+ decls' <- typeCheckAll mainModuleName mn exps decls
+ forM_ exps $ \e -> do
+ checkTypesAreExported e
+ checkClassMembersAreExported e
+ checkClassesAreExported e
+ return $ Module mn decls' (Just exps)
+ where
+ checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()
+ checkMemberExport thing extract test (ValueRef name) = do
+ ty <- lookupVariable mn (Qualified (Just mn) name)
+ case find test (extract ty) of
+ Just hiddenType -> throwError . strMsg $
+ "Error in module '" ++ show mn ++ "':\n\
+ \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"
+ Nothing -> return ()
+ checkMemberExport _ _ _ _ = return ()
+ -- Check that all the type constructors defined in the current module that appear in member types
+ -- have also been exported from the module
+ checkTypesAreExported :: DeclarationRef -> Check ()
+ checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden
+ where
+ findTcons :: Type -> [ProperName]
+ findTcons = everythingOnTypes (++) go
+ where
+ go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
+ go _ = []
+ isTconHidden :: ProperName -> Bool
+ isTconHidden tyName = all go exps
+ where
+ go (TypeRef tyName' _) = tyName' /= tyName
+ go _ = True
+ -- Check that all the classes defined in the current module that appear in member types have also
+ -- been exported from the module
+ checkClassesAreExported :: DeclarationRef -> Check ()
+ checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden
+ where
+ findClasses :: Type -> [ProperName]
+ findClasses = everythingOnTypes (++) go
+ where
+ go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs
+ go _ = []
+ extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
+ extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
+ extractCurrentModuleClass _ = Nothing
+ isClassHidden :: ProperName -> Bool
+ isClassHidden clsName = all go exps
+ where
+ go (TypeClassRef clsName') = clsName' /= clsName
+ go _ = True
+
+ checkClassMembersAreExported :: DeclarationRef -> Check ()
+ checkClassMembersAreExported (TypeClassRef name) = do
+ let members = ValueRef `map` head (mapMaybe findClassMembers decls)
+ let missingMembers = members \\ exps
+ unless (null missingMembers) $
+ throwError . strMsg $
+ "Error in module '" ++ show mn ++ "':\n\
+ \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"
+ where
+ runValueRef :: DeclarationRef -> Ident
+ runValueRef (ValueRef refName) = refName
+ runValueRef _ = error "non-ValueRef passed to runValueRef"
+ findClassMembers :: Declaration -> Maybe [Ident]
+ findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
+ findClassMembers (PositionedDeclaration _ d) = findClassMembers d
+ findClassMembers _ = Nothing
+ extractMemberName :: Declaration -> Ident
+ extractMemberName (PositionedDeclaration _ d) = extractMemberName d
+ extractMemberName (TypeDeclaration memberName _) = memberName
+ extractMemberName _ = error "Unexpected declaration in typeclass member list"
+ checkClassMembersAreExported _ = return ()
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 26551a9..1a7f168 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -80,20 +80,27 @@ kindOf _ ty =
-- |
-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
--
-kindsOf :: Bool -> ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
+kindsOf :: Bool -> ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Type] -> Check Kind
kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
tyCon <- fresh
kargs <- replicateM (length args) fresh
- let dict = (name, tyCon) : zipWith (\arg kind -> (arg, kind)) (map ProperName args) kargs
+ rest <- zipWithM freshKindVar args kargs
+ let dict = (name, tyCon) : rest
bindLocalTypeVariables moduleName dict $
solveTypes isData ts kargs tyCon
where
tidyUp (k, sub) = starIfUnknown $ sub $? k
+
+freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind)
+freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)
+freshKindVar (arg, Just kind') kind = do
+ kind =?= kind'
+ return (ProperName arg, kind')
-- |
-- Simultaneously infer the kinds of several mutually recursive type constructors
--
-kindsOfAll :: ModuleName -> [(ProperName, [String], Type)] -> [(ProperName, [String], [Type])] -> Check ([Kind], [Kind])
+kindsOfAll :: ModuleName -> [(ProperName, [(String, Maybe Kind)], Type)] -> [(ProperName, [(String, Maybe Kind)], [Type])] -> Check ([Kind], [Kind])
kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
synVars <- replicateM (length syns) fresh
let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
@@ -103,12 +110,12 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
bindLocalTypeVariables moduleName dict' $ do
data_ks <- zipWithM (\tyCon (_, args, ts) -> do
kargs <- replicateM (length args) fresh
- let argDict = zip (map ProperName args) kargs
+ argDict <- zipWithM freshKindVar args kargs
bindLocalTypeVariables moduleName argDict $
solveTypes True ts kargs tyCon) tyCons tys
syn_ks <- zipWithM (\synVar (_, args, ty) -> do
kargs <- replicateM (length args) fresh
- let argDict = zip (map ProperName args) kargs
+ argDict <- zipWithM freshKindVar args kargs
bindLocalTypeVariables moduleName argDict $
solveTypes False [ty] kargs synVar) synVars syns
return (syn_ks, data_ks)
@@ -179,6 +186,10 @@ infer' (ConstrainedType deps ty) = do
k <- infer ty
k =?= Star
return Star
+infer' (KindedType ty k) = do
+ k' <- infer ty
+ k =?= k'
+ return k'
infer' _ = error "Invalid argument to infer"
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 4aac6e0..a9c45b2 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -124,6 +124,8 @@ unifyTypes t1 t2 = rethrow (mkErrorStack ("Error unifying type " ++ prettyPrintT
t3 `unifyTypes` t5
t4 `unifyTypes` t6
unifyTypes' (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = return ()
+ unifyTypes' (KindedType ty1 _) ty2 = ty1 `unifyTypes` ty2
+ unifyTypes' ty1 (KindedType ty2 _) = ty1 `unifyTypes` ty2
unifyTypes' r1@RCons{} r2 = unifyRows r1 r2
unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
unifyTypes' r1@REmpty r2 = unifyRows r1 r2
@@ -154,12 +156,12 @@ unifyRows r1 r2 =
unifyRows' :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> UnifyT Type Check ()
unifyRows' [] (TUnknown u) sd r = u =:= rowFromList (sd, r)
unifyRows' sd r [] (TUnknown u) = u =:= rowFromList (sd, r)
- unifyRows' ((name, ty):row) r others u@(TUnknown un) = do
- occursCheck un ty
- forM_ row $ \(_, t) -> occursCheck un t
- u' <- fresh
- u =?= RCons name ty u'
- unifyRows' row r others u'
+ unifyRows' sd1 (TUnknown u1) sd2 (TUnknown u2) = do
+ forM_ sd1 $ \(_, t) -> occursCheck u2 t
+ forM_ sd2 $ \(_, t) -> occursCheck u1 t
+ rest <- fresh
+ u1 =:= rowFromList (sd2, rest)
+ u2 =:= rowFromList (sd1, rest)
unifyRows' [] REmpty [] REmpty = return ()
unifyRows' [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = return ()
unifyRows' [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = return ()
@@ -188,6 +190,8 @@ typesOf mainModuleName moduleName vals = do
val' <- replaceTypeClassDictionaries moduleName val
-- Check skolem variables did not escape their scope
skolemEscapeCheck val'
+ -- Check rows do not contain duplicate labels
+ checkDuplicateLabels val'
-- Remove type synonyms placeholders, remove duplicate row fields, and replace
-- top-level unification variables with named type variables.
let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'
@@ -316,89 +320,119 @@ entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filt
filterModule _ = False
solve context' (className, tys) trySuperclasses =
- let
- dicts = go trySuperclasses className tys
- in case sortedNubBy dictTrace (chooseSimplestDictionaries dicts) of
- [] -> throwError . strMsg $ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
- [_] -> return $ dictionaryValueToValue $ head dicts
- _ -> throwError . strMsg $ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
+ checkOverlaps $ go trySuperclasses className tys
where
- go trySuperclasses' className' tys' =
- -- Look for regular type instances
- [ mkDictionary (canonicalizeDictionary tcd) args
- | tcd <- context'
- -- Make sure the type class name matches the one we are trying to satisfy
- , className' == tcdClassName tcd
- -- Make sure the type unifies with the type in the type instance definition
- , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
- -- Solve any necessary subgoals
- , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
-
- -- Look for implementations via superclasses
- [ SubclassDictionaryValue suDict superclass index
- | trySuperclasses'
- , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
- -- Try each superclass
- , (index, (superclass, suTyArgs)) <- zip [0..] implies
- -- Make sure the type class name matches the superclass name
- , className' == superclass
- -- Make sure the types unify with the types in the superclass implication
- , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
- -- Finally, satisfy the subclass constraint
- , args' <- maybeToList $ mapM (flip lookup subst) args
- , suDict <- go True subclassName args' ]
-
- -- Create dictionaries for subgoals which still need to be solved by calling go recursively
- -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
- -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
- solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
- solveSubgoals _ Nothing = return Nothing
- solveSubgoals subst (Just subgoals) = do
- dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
- return $ Just dict
- -- Make a dictionary from subgoal dictionaries by applying the correct function
- mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
- mkDictionary fnName Nothing = LocalDictionaryValue fnName
- mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
- mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
- -- Turn a DictionaryValue into a Expr
- dictionaryValueToValue :: DictionaryValue -> Expr
- dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
- dictionaryValueToValue (GlobalDictionaryValue fnName) = App (Var fnName) valUndefined
- dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
- dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
- App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
- (dictionaryValueToValue dict))
- valUndefined
- -- Ensure that a substitution is valid
- verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
- verifySubstitution subst = do
- let grps = groupBy ((==) `on` fst) subst
- guard (all (pairwise (unifiesWith env) . map snd) grps)
- return $ map head grps
- -- Choose the simplest DictionaryValues from a list of candidates
- -- The reason for this function is as follows:
- -- When considering overlapping instances, we don't want to consider the same dictionary
- -- to be an overlap of itself when obtained as a superclass of another class.
- -- Observing that we probably don't want to select a superclass instance when an instance
- -- is available directly, and that there is no way for a superclass instance to actually
- -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
- -- obtained as superclass instances if there are simpler instances available.
- chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
- chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
- [] -> ds
- simple -> simple
- isSimpleDictionaryValue SubclassDictionaryValue{} = False
- isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
- isSimpleDictionaryValue _ = True
- -- |
- -- Get the "trace" of a DictionaryValue - that is, remove all SubclassDictionaryValue
- -- data constructors
- --
- dictTrace :: DictionaryValue -> DictionaryValue
- dictTrace (DependentDictionaryValue fnName dicts) = DependentDictionaryValue fnName $ map dictTrace dicts
- dictTrace (SubclassDictionaryValue dict _ _) = dictTrace dict
- dictTrace other = other
+ go trySuperclasses' className' tys' =
+ -- Look for regular type instances
+ [ mkDictionary (canonicalizeDictionary tcd) args
+ | tcd <- context'
+ -- Make sure the type class name matches the one we are trying to satisfy
+ , className' == tcdClassName tcd
+ -- Make sure the type unifies with the type in the type instance definition
+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
+ -- Solve any necessary subgoals
+ , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
+
+ -- Look for implementations via superclasses
+ [ SubclassDictionaryValue suDict superclass index
+ | trySuperclasses'
+ , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
+ -- Try each superclass
+ , (index, (superclass, suTyArgs)) <- zip [0..] implies
+ -- Make sure the type class name matches the superclass name
+ , className' == superclass
+ -- Make sure the types unify with the types in the superclass implication
+ , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
+ -- Finally, satisfy the subclass constraint
+ , args' <- maybeToList $ mapM (flip lookup subst) (map fst args)
+ , suDict <- go True subclassName args' ]
+
+ -- Create dictionaries for subgoals which still need to be solved by calling go recursively
+ -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
+ -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
+ solveSubgoals :: [(String, Type)] -> Maybe [(Qualified ProperName, [Type])] -> [Maybe [DictionaryValue]]
+ solveSubgoals _ Nothing = return Nothing
+ solveSubgoals subst (Just subgoals) = do
+ dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
+ return $ Just dict
+ -- Make a dictionary from subgoal dictionaries by applying the correct function
+ mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
+ mkDictionary fnName Nothing = LocalDictionaryValue fnName
+ mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
+ mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
+ -- Turn a DictionaryValue into a Expr
+ dictionaryValueToValue :: DictionaryValue -> Expr
+ dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
+ dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName
+ dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
+ dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
+ App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
+ (dictionaryValueToValue dict))
+ valUndefined
+ -- Ensure that a substitution is valid
+ verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
+ verifySubstitution subst = do
+ let grps = groupBy ((==) `on` fst) subst
+ guard (all (pairwise (unifiesWith env) . map snd) grps)
+ return $ map head grps
+ -- |
+ -- Check for overlapping instances
+ --
+ checkOverlaps :: [DictionaryValue] -> Check Expr
+ checkOverlaps dicts =
+ case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of
+ (d1, d2) : _ -> throwError . strMsg $ unlines
+ [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."
+ , "For example:"
+ , prettyPrintDictionaryValue d1
+ , "and:"
+ , prettyPrintDictionaryValue d2
+ ]
+ _ -> case chooseSimplestDictionaries dicts of
+ [] -> throwError . strMsg $
+ "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
+ d : _ -> return $ dictionaryValueToValue d
+ -- Choose the simplest DictionaryValues from a list of candidates
+ -- The reason for this function is as follows:
+ -- When considering overlapping instances, we don't want to consider the same dictionary
+ -- to be an overlap of itself when obtained as a superclass of another class.
+ -- Observing that we probably don't want to select a superclass instance when an instance
+ -- is available directly, and that there is no way for a superclass instance to actually
+ -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
+ -- obtained as superclass instances if there are simpler instances available.
+ chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
+ chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
+ [] -> ds
+ simple -> simple
+ isSimpleDictionaryValue SubclassDictionaryValue{} = False
+ isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
+ isSimpleDictionaryValue _ = True
+ -- |
+ -- Check if two dictionaries are overlapping
+ --
+ -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
+ -- been caught when constructing superclass dictionaries.
+ --
+ overlapping :: DictionaryValue -> DictionaryValue -> Bool
+ overlapping (LocalDictionaryValue nm1) (LocalDictionaryValue nm2) | nm1 == nm2 = False
+ overlapping (GlobalDictionaryValue nm1) (GlobalDictionaryValue nm2) | nm1 == nm2 = False
+ overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2)
+ | nm1 == nm2 = any id $ zipWith overlapping ds1 ds2
+ overlapping (SubclassDictionaryValue _ _ _) _ = False
+ overlapping _ (SubclassDictionaryValue _ _ _) = False
+ overlapping _ _ = True
+ -- |
+ -- Render a DictionaryValue fit for human consumption in error messages
+ --
+ prettyPrintDictionaryValue :: DictionaryValue -> String
+ prettyPrintDictionaryValue = unlines . indented 0
+ where
+ indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]
+ indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]
+ indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args
+ indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup
+
+ spaces n = replicate n ' ' ++ "- "
valUndefined :: Expr
valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
@@ -482,6 +516,41 @@ skolemEscapeCheck root@TypedValue{} =
skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
-- |
+-- Ensure rows do not contain duplicate labels
+--
+checkDuplicateLabels :: Expr -> Check ()
+checkDuplicateLabels =
+ let (_, f, _) = everywhereOnValuesM def go def
+ in void . f
+ where
+ def :: a -> Check a
+ def = return
+
+ go :: Expr -> Check Expr
+ go e@(TypedValue _ _ ty) = checkDups ty >> return e
+ go other = return other
+
+ checkDups :: Type -> Check ()
+ checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
+ checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts
+ checkDups (ForAll _ t _) = checkDups t
+ checkDups (ConstrainedType args t) = do
+ mapM_ (checkDups) $ concatMap snd args
+ checkDups t
+ checkDups r@(RCons _ _ _) =
+ let (ls, _) = rowToList r in
+ case firstDup . sort . map fst $ ls of
+ Just l -> throwError . strMsg $ "Duplicate label " ++ show l ++ " in row"
+ Nothing -> return ()
+ checkDups _ = return ()
+
+ firstDup :: (Eq a) => [a] -> Maybe a
+ firstDup (x : xs@(x' : _))
+ | x == x' = Just x
+ | otherwise = firstDup xs
+ firstDup _ = Nothing
+
+-- |
-- Ensure a row contains no duplicate labels
--
setify :: Type -> Type
@@ -563,7 +632,7 @@ expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either St
expandTypeSynonym' env name args =
case M.lookup name (typeSynonyms env) of
Just (synArgs, body) -> do
- let repl = replaceAllTypeVars (zip synArgs args) body
+ let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
replaceAllTypeSynonyms' env repl
Nothing -> error "Type synonym was not defined"
@@ -974,6 +1043,10 @@ check' (Let ds val) ty = do
check' val ty | containsTypeSynonyms ty = do
ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty
check val ty'
+check' val kt@(KindedType ty kind) = do
+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
+ val' <- check' val ty
+ return $ TypedValue True val' kt
check' (PositionedValue pos val) ty =
rethrowWithPosition pos $ check val ty
check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))
@@ -1056,6 +1129,8 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do
checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
checkFunctionApplication fn ty arg ret
+checkFunctionApplication' fn (KindedType ty _) arg ret = do
+ checkFunctionApplication fn ty arg ret
checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
dicts <- getTypeClassDictionaries
checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret
@@ -1100,6 +1175,10 @@ subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do
subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
subsumes val ty1 ty2
+subsumes' val (KindedType ty1 _) ty2 = do
+ subsumes val ty1 ty2
+subsumes' val ty1 (KindedType ty2 _) = do
+ subsumes val ty1 ty2
subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
dicts <- getTypeClassDictionaries
subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 083bd22..0fad74d 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -26,6 +26,7 @@ import Control.Applicative
import Control.Monad ((<=<))
import Language.PureScript.Names
+import Language.PureScript.Kinds
import Language.PureScript.Traversals
-- |
@@ -78,6 +79,11 @@ data Type
--
| RCons String Type Type
-- |
+ -- A type with a kind annotation
+ --
+ | KindedType Type Kind
+ --
+ -- |
-- A placeholder used in pretty printing
--
| PrettyPrintFunction Type Type
@@ -126,23 +132,36 @@ mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args
-- Replace a type variable, taking into account variable shadowing
--
replaceTypeVars :: String -> Type -> Type -> Type
-replaceTypeVars = replaceTypeVars' []
+replaceTypeVars v r = replaceAllTypeVars [(v, r)]
+
+-- |
+-- Replace named type variables with types
+--
+replaceAllTypeVars :: [(String, Type)] -> Type -> Type
+replaceAllTypeVars = go []
where
- replaceTypeVars' bound name replacement = go bound
+
+ go :: [String] -> [(String, Type)] -> Type -> Type
+ go _ m (TypeVar v) =
+ case v `lookup` m of
+ Just r -> r
+ Nothing -> TypeVar v
+ go bs m (TypeApp t1 t2) = TypeApp (go bs m t1) (go bs m t2)
+ go bs m (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs m) ts
+ go bs m f@(ForAll v t sco) | v `elem` keys = go bs (filter ((/= v) . fst) m) f
+ | v `elem` usedVars =
+ let v' = genName v (keys ++ bs ++ usedVars)
+ t' = go bs [(v, TypeVar v')] t
+ in ForAll v' (go (v' : bs) m t') sco
+ | otherwise = ForAll v (go (v : bs) m t) sco
where
- go :: [String] -> Type -> Type
- go _ (TypeVar v) | v == name = replacement
- go bs (TypeApp t1 t2) = TypeApp (go bs t1) (go bs t2)
- go bs (SaturatedTypeSynonym name' ts) = SaturatedTypeSynonym name' $ map (go bs) ts
- go bs f@(ForAll v t sco) | v == name = f
- | v `elem` usedTypeVariables replacement =
- let v' = genName v (name : bs ++ usedTypeVariables replacement)
- t' = replaceTypeVars' bs v (TypeVar v') t
- in ForAll v' (go (v' : bs) t') sco
- | otherwise = ForAll v (go (v : bs) t) sco
- go bs (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs)) cs) (go bs t)
- go bs (RCons name' t r) = RCons name' (go bs t) (go bs r)
- go _ ty = ty
+ keys = map fst m
+ usedVars = concatMap (usedTypeVariables . snd) m
+ go bs m (ConstrainedType cs t) = ConstrainedType (map (second $ map (go bs m)) cs) (go bs m t)
+ go bs m (RCons name' t r) = RCons name' (go bs m t) (go bs m r)
+ go bs m (KindedType t k) = KindedType (go bs m t) k
+ go _ _ ty = ty
+
genName orig inUse = try 0
where
try :: Integer -> String
@@ -150,12 +169,6 @@ replaceTypeVars = replaceTypeVars' []
| otherwise = orig ++ show n
-- |
--- Replace named type variables with types
---
-replaceAllTypeVars :: [(String, Type)] -> Type -> Type
-replaceAllTypeVars = foldl (\f (name, ty) -> replaceTypeVars name ty . f) id
-
--- |
-- Collect all type variables appearing in a type
--
usedTypeVariables :: Type -> [String]
@@ -177,6 +190,7 @@ freeTypeVariables = nub . go []
go bound (ForAll v t _) = go (v : bound) t
go bound (ConstrainedType cs t) = concatMap (concatMap (go bound) . snd) cs ++ go bound t
go bound (RCons _ t r) = go bound t ++ go bound r
+ go bound (KindedType t _) = go bound t
go _ _ = []
-- |
@@ -213,6 +227,7 @@ everywhereOnTypes f = go
go (ForAll arg ty sco) = f (ForAll arg (go ty) sco)
go (ConstrainedType cs ty) = f (ConstrainedType (map (fmap (map go)) cs) (go ty))
go (RCons name ty rest) = f (RCons name (go ty) (go rest))
+ go (KindedType ty k) = f (KindedType (go ty) k)
go (PrettyPrintFunction t1 t2) = f (PrettyPrintFunction (go t1) (go t2))
go (PrettyPrintArray t) = f (PrettyPrintArray (go t))
go (PrettyPrintObject t) = f (PrettyPrintObject (go t))
@@ -227,6 +242,7 @@ everywhereOnTypesTopDown f = go . f
go (ForAll arg ty sco) = ForAll arg (go (f ty)) sco
go (ConstrainedType cs ty) = ConstrainedType (map (fmap (map (go . f))) cs) (go (f ty))
go (RCons name ty rest) = RCons name (go (f ty)) (go (f rest))
+ go (KindedType ty k) = KindedType (go (f ty)) k
go (PrettyPrintFunction t1 t2) = PrettyPrintFunction (go (f t1)) (go (f t2))
go (PrettyPrintArray t) = PrettyPrintArray (go (f t))
go (PrettyPrintObject t) = PrettyPrintObject (go (f t))
@@ -241,6 +257,7 @@ everywhereOnTypesM f = go
go (ForAll arg ty sco) = (ForAll arg <$> go ty <*> pure sco) >>= f
go (ConstrainedType cs ty) = (ConstrainedType <$> mapM (sndM (mapM go)) cs <*> go ty) >>= f
go (RCons name ty rest) = (RCons name <$> go ty <*> go rest) >>= f
+ go (KindedType ty k) = (KindedType <$> go ty <*> pure k) >>= f
go (PrettyPrintFunction t1 t2) = (PrettyPrintFunction <$> go t1 <*> go t2) >>= f
go (PrettyPrintArray t) = (PrettyPrintArray <$> go t) >>= f
go (PrettyPrintObject t) = (PrettyPrintObject <$> go t) >>= f
@@ -255,6 +272,7 @@ everywhereOnTypesTopDownM f = go <=< f
go (ForAll arg ty sco) = ForAll arg <$> (f ty >>= go) <*> pure sco
go (ConstrainedType cs ty) = ConstrainedType <$> mapM (sndM (mapM (go <=< f))) cs <*> (f ty >>= go)
go (RCons name ty rest) = RCons name <$> (f ty >>= go) <*> (f rest >>= go)
+ go (KindedType ty k) = KindedType <$> (f ty >>= go) <*> pure k
go (PrettyPrintFunction t1 t2) = PrettyPrintFunction <$> (f t1 >>= go) <*> (f t2 >>= go)
go (PrettyPrintArray t) = PrettyPrintArray <$> (f t >>= go)
go (PrettyPrintObject t) = PrettyPrintObject <$> (f t >>= go)
@@ -269,6 +287,7 @@ everythingOnTypes (<>) f = go
go t@(ForAll _ ty _) = f t <> go ty
go t@(ConstrainedType cs ty) = foldl (<>) (f t) (map go $ concatMap snd cs) <> go ty
go t@(RCons _ ty rest) = f t <> go ty <> go rest
+ go t@(KindedType ty _) = f t <> go ty
go t@(PrettyPrintFunction t1 t2) = f t <> go t1 <> go t2
go t@(PrettyPrintArray t1) = f t <> go t1
go t@(PrettyPrintObject t1) = f t <> go t1