summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2014-03-26 00:40:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2014-03-26 00:40:00 (GMT)
commitdea419160ee3766eadd4d1b5ca85f13e994c6dda (patch)
tree712f0ec40f88d33df5fd5a055e5226878ef5e618
parentb9baa7b73886d2681f3474e5304496477729db2b (diff)
version 0.4.90.4.9
-rw-r--r--prelude/prelude.purs58
-rw-r--r--psc-make/Main.hs14
-rw-r--r--psc/Main.hs14
-rw-r--r--psci/Main.hs3
-rw-r--r--psci/Parser.hs4
-rw-r--r--purescript.cabal6
-rw-r--r--src/Language/PureScript.hs79
-rw-r--r--src/Language/PureScript/CodeGen/Externs.hs2
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs4
-rw-r--r--src/Language/PureScript/DeadCodeElimination.hs1
-rw-r--r--src/Language/PureScript/Declarations.hs196
-rw-r--r--src/Language/PureScript/Environment.hs9
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs2
-rw-r--r--src/Language/PureScript/Optimizer/MagicDo.hs23
-rw-r--r--src/Language/PureScript/Optimizer/TCO.hs4
-rw-r--r--src/Language/PureScript/Options.hs14
-rw-r--r--src/Language/PureScript/Parser.hs1
-rw-r--r--src/Language/PureScript/Parser/Common.hs11
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs251
-rw-r--r--src/Language/PureScript/Parser/Types.hs2
-rw-r--r--src/Language/PureScript/Parser/Values.hs246
-rw-r--r--src/Language/PureScript/Pretty/Types.hs8
-rw-r--r--src/Language/PureScript/Pretty/Values.hs3
-rw-r--r--src/Language/PureScript/Scope.hs2
-rw-r--r--src/Language/PureScript/Sugar.hs9
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs18
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs9
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs2
-rw-r--r--src/Language/PureScript/Sugar/Let.hs34
-rw-r--r--src/Language/PureScript/Sugar/Names.hs77
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs2
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs6
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs9
-rw-r--r--src/Language/PureScript/TypeChecker.hs6
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs26
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs2
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs156
-rw-r--r--src/Language/PureScript/TypeClassDictionaries.hs62
-rw-r--r--src/Language/PureScript/Types.hs16
-rw-r--r--src/Language/PureScript/Values.hs254
40 files changed, 862 insertions, 783 deletions
diff --git a/prelude/prelude.purs b/prelude/prelude.purs
index 411cfcd..23923a4 100644
--- a/prelude/prelude.purs
+++ b/prelude/prelude.purs
@@ -139,24 +139,38 @@ module Prelude where
(%) = numMod
negate = numNegate
- infixl 4 ==
- infixl 4 /=
+ infix 4 ==
+ infix 4 /=
class Eq a where
(==) :: a -> a -> Boolean
(/=) :: a -> a -> Boolean
+ foreign import refEq
+ "function refEq(r1) {\
+ \ return function(r2) {\
+ \ return r1 === r2;\
+ \ };\
+ \}" :: forall a. a -> a -> Boolean
+
+ foreign import refIneq
+ "function refIneq(r1) {\
+ \ return function(r2) {\
+ \ return r1 !== r2;\
+ \ };\
+ \}" :: forall a. a -> a -> Boolean
+
instance eqString :: Eq String where
- (==) = Data.Eq.Unsafe.refEq
- (/=) = Data.Eq.Unsafe.refIneq
+ (==) = refEq
+ (/=) = refIneq
instance eqNumber :: Eq Number where
- (==) = Data.Eq.Unsafe.refEq
- (/=) = Data.Eq.Unsafe.refIneq
+ (==) = refEq
+ (/=) = refIneq
instance eqBoolean :: Eq Boolean where
- (==) = Data.Eq.Unsafe.refEq
- (/=) = Data.Eq.Unsafe.refIneq
+ (==) = refEq
+ (/=) = refIneq
instance eqArray :: (Eq a) => Eq [a] where
(==) [] [] = true
@@ -321,38 +335,14 @@ module Prelude where
module Data.Eq where
- import qualified Data.Eq.Unsafe as Unsafe
-
data Ref a = Ref a
liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
liftRef f (Ref x) (Ref y) = f x y
- refEq :: forall a. Ref a -> Ref a -> Boolean
- refEq = liftRef Unsafe.refEq
-
- refIneq :: forall a. Ref a -> Ref a -> Boolean
- refIneq = liftRef Unsafe.refIneq
-
instance eqRef :: Eq (Ref a) where
- (==) = refEq
- (/=) = refIneq
-
-module Data.Eq.Unsafe where
-
- foreign import refEq
- "function refEq(r1) {\
- \ return function(r2) {\
- \ return r1 === r2;\
- \ };\
- \}" :: forall a. a -> a -> Boolean
-
- foreign import refIneq
- "function refIneq(r1) {\
- \ return function(r2) {\
- \ return r1 !== r2;\
- \ };\
- \}" :: forall a. a -> a -> Boolean
+ (==) = liftRef refEq
+ (/=) = liftRef refIneq
module Control.Monad.Eff where
diff --git a/psc-make/Main.hs b/psc-make/Main.hs
index 877c96c..e8eda43 100644
--- a/psc-make/Main.hs
+++ b/psc-make/Main.hs
@@ -91,9 +91,9 @@ inputFiles :: Term [FilePath]
inputFiles = value $ posAny [] $ posInfo
{ posDoc = "The input .ps files" }
-tco :: Term Bool
-tco = value $ flag $ (optInfo [ "tco" ])
- { optDoc = "Perform tail call optimizations" }
+noTco :: Term Bool
+noTco = value $ flag $ (optInfo [ "no-tco" ])
+ { optDoc = "Disable tail call optimizations" }
performRuntimeTypeChecks :: Term Bool
performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
@@ -103,9 +103,9 @@ noPrelude :: Term Bool
noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
{ optDoc = "Omit the Prelude" }
-magicDo :: Term Bool
-magicDo = value $ flag $ (optInfo [ "magic-do" ])
- { optDoc = "Overload the do keyword to generate efficient code specifically for the Eff monad." }
+noMagicDo :: Term Bool
+noMagicDo = value $ flag $ (optInfo [ "no-magic-do" ])
+ { optDoc = "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad." }
noOpts :: Term Bool
noOpts = value $ flag $ (optInfo [ "no-opts" ])
@@ -116,7 +116,7 @@ browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
{ optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
options :: Term P.Options
-options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure []
+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure []
inputFilesAndPrelude :: FilePath -> Term [FilePath]
inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
diff --git a/psc/Main.hs b/psc/Main.hs
index b37fae8..bb0e1f9 100644
--- a/psc/Main.hs
+++ b/psc/Main.hs
@@ -86,9 +86,9 @@ externsFile :: Term (Maybe FilePath)
externsFile = value $ opt Nothing $ (optInfo [ "e", "externs" ])
{ optDoc = "The output .e.ps file" }
-tco :: Term Bool
-tco = value $ flag $ (optInfo [ "tco" ])
- { optDoc = "Perform tail call optimizations" }
+noTco :: Term Bool
+noTco = value $ flag $ (optInfo [ "no-tco" ])
+ { optDoc = "Disable tail call optimizations" }
performRuntimeTypeChecks :: Term Bool
performRuntimeTypeChecks = value $ flag $ (optInfo [ "runtime-type-checks" ])
@@ -98,9 +98,9 @@ noPrelude :: Term Bool
noPrelude = value $ flag $ (optInfo [ "no-prelude" ])
{ optDoc = "Omit the Prelude" }
-magicDo :: Term Bool
-magicDo = value $ flag $ (optInfo [ "magic-do" ])
- { optDoc = "Overload the do keyword to generate efficient code specifically for the Eff monad." }
+noMagicDo :: Term Bool
+noMagicDo = value $ flag $ (optInfo [ "no-magic-do" ])
+ { optDoc = "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad." }
runMain :: Term (Maybe String)
runMain = value $ defaultOpt (Just "Main") Nothing $ (optInfo [ "main" ])
@@ -123,7 +123,7 @@ codeGenModules = value $ optAll [] $ (optInfo [ "codegen" ])
{ optDoc = "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times." }
options :: Term P.Options
-options = P.Options <$> tco <*> performRuntimeTypeChecks <*> magicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules
+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules
stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
diff --git a/psci/Main.hs b/psci/Main.hs
index 5d2e787..b9b14ab 100644
--- a/psci/Main.hs
+++ b/psci/Main.hs
@@ -161,7 +161,6 @@ quitMessage = "See ya!"
-- |
-- Loads module, function, and file completions.
--- TODO: filter names to only include exported decls
--
completion :: CompletionFunc (StateT PSCiState IO)
completion = completeWord Nothing " \t\n\r" findCompletions
@@ -195,7 +194,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions
-- | Compilation options.
--
options :: P.Options
-options = P.Options True False True (Just "Main") True "PS" [] []
+options = P.Options False True False True (Just "Main") True "PS" [] []
-- |
-- Makes a volatile module to execute the current expression.
diff --git a/psci/Parser.hs b/psci/Parser.hs
index 2cc52ee..6d12b00 100644
--- a/psci/Parser.hs
+++ b/psci/Parser.hs
@@ -26,6 +26,7 @@ import Control.Applicative hiding (many)
import Text.Parsec hiding ((<|>))
import qualified Language.PureScript as P
+import qualified Language.PureScript.Parser.Common as C (mark, same)
-- |
-- PSCI version of @let@.
@@ -34,8 +35,7 @@ import qualified Language.PureScript as P
-- we actually want the normal @let@.
--
psciLet :: Parsec String P.ParseState Command
-psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> (Left <$> P.parseBinder))
- <*> (P.indented *> P.reservedOp "=" *> P.parseValue))
+psciLet = Let <$> (P.Let <$> (P.reserved "let" *> P.indented *> C.mark (many1 (C.same *> P.parseDeclaration))))
-- |
-- Parses PSCI metacommands or expressions input from the user.
diff --git a/purescript.cabal b/purescript.cabal
index 9d301c8..467472d 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,5 +1,5 @@
name: purescript
-version: 0.4.8
+version: 0.4.9
cabal-version: >=1.8
build-type: Custom
license: MIT
@@ -33,8 +33,8 @@ library
Language.PureScript.Kinds
Language.PureScript.Names
Language.PureScript.Types
- Language.PureScript.Values
Language.PureScript.Scope
+ Language.PureScript.TypeClassDictionaries
Language.PureScript.DeadCodeElimination
Language.PureScript.Sugar
Language.PureScript.ModuleDependencies
@@ -44,7 +44,6 @@ library
Language.PureScript.Sugar.BindingGroups
Language.PureScript.Sugar.Operators
Language.PureScript.Sugar.TypeClasses
- Language.PureScript.Sugar.Let
Language.PureScript.Sugar.Names
Language.PureScript.CodeGen
Language.PureScript.CodeGen.Common
@@ -65,7 +64,6 @@ library
Language.PureScript.Parser.Kinds
Language.PureScript.Parser.State
Language.PureScript.Parser.Types
- Language.PureScript.Parser.Values
Language.PureScript.Pretty
Language.PureScript.Pretty.Common
Language.PureScript.Pretty.JS
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index 09a364b..4323055 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -15,7 +15,6 @@
module Language.PureScript (module P, compile, compile', MonadMake(..), make) where
-import Language.PureScript.Values as P
import Language.PureScript.Types as P
import Language.PureScript.Kinds as P
import Language.PureScript.Declarations as P
@@ -33,13 +32,15 @@ import Language.PureScript.DeadCodeElimination as P
import qualified Language.PureScript.Constants as C
-import Data.List (sortBy, groupBy, intercalate)
+import Data.List (find, sortBy, groupBy, intercalate)
import Data.Time.Clock
import Data.Function (on)
+import Data.Generics (mkQ, everything)
import Data.Maybe (fromMaybe, mapMaybe)
+import Control.Monad.Error
import Control.Monad.State.Lazy
import Control.Arrow ((&&&))
-import Control.Applicative ((<$>), (<*>), pure)
+import Control.Applicative ((<$>))
import qualified Data.Map as M
import qualified Data.Set as S
import System.FilePath (pathSeparator)
@@ -68,11 +69,9 @@ compile = compile' initEnvironment
compile' :: Environment -> Options -> [Module] -> Either String (String, String, Environment)
compile' env opts ms = do
- (sorted, _) <- sortModules ms
+ (sorted, _) <- sortModules $ if optionsNoPrelude opts then ms else (map importPrelude ms)
desugared <- desugar sorted
- (elaborated, env') <- runCheck' env $ forM desugared $ \(Module moduleName' decls exps) -> do
- modify (\s -> s { checkCurrentModule = Just moduleName' })
- Module moduleName' <$> typeCheckAll mainModuleIdent moduleName' decls <*> pure exps
+ (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
let entryPoints = moduleNameFromString `map` optionsModules opts
let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
@@ -85,6 +84,42 @@ compile' env opts ms = 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 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 $ "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 = everything (++) (mkQ [] 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 -> [JS] -> Either String [JS]
generateMain env opts js =
case moduleNameFromString <$> optionsMain opts of
@@ -127,9 +162,9 @@ class MonadMake m where
--
make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()
make opts ms = do
- let filePathMap = M.fromList (map (\(fp, (Module mn _ _)) -> (mn, fp)) ms)
+ let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
- (sorted, graph) <- liftError $ sortModules (map snd ms)
+ (sorted, graph) <- liftError $ sortModules $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)
toRebuild <- foldM (\s (Module moduleName' _ _) -> do
let filePath = toFileName moduleName'
@@ -155,20 +190,16 @@ make opts ms = do
where
go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
go _ [] = return ()
- go env ((False, Module moduleName' typings _) : ms') = do
- (_, env') <- liftError . runCheck' env $ do
- modify (\s -> s { checkCurrentModule = Just moduleName' })
- typeCheckAll Nothing moduleName' typings
+ go env ((False, m) : ms') = do
+ (_, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
go env' ms'
- go env ((True, Module moduleName' decls exps) : ms') = do
+ go env ((True, m@(Module moduleName' _ exps)) : ms') = do
let filePath = toFileName moduleName'
jsFile = "js" ++ pathSeparator : filePath ++ ".js"
externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
- (elaborated, env') <- liftError . runCheck' env $ do
- modify (\s -> s { checkCurrentModule = Just moduleName' })
- typeCheckAll Nothing moduleName' decls
+ (Module _ elaborated _, env') <- liftError . runCheck' env $ typeCheckModule Nothing m
regrouped <- liftError . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
@@ -204,3 +235,17 @@ reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
where
combine :: (Ord a) => [(a, b)] -> M.Map a [b]
combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
+
+-- |
+-- Add an import declaration for the Prelude to a module if it does not already explicitly import
+-- it.
+--
+importPrelude :: Module -> Module
+importPrelude m@(Module mn decls exps) =
+ if isPreludeImport `any` decls || mn == prelude then m
+ else Module mn (preludeImport : decls) exps
+ where
+ prelude = ModuleName [ProperName C.prelude]
+ isPreludeImport (ImportDeclaration (ModuleName [ProperName mn']) _ _) | mn' == C.prelude = True
+ isPreludeImport _ = False
+ preludeImport = ImportDeclaration prelude Nothing Nothing
diff --git a/src/Language/PureScript/CodeGen/Externs.hs b/src/Language/PureScript/CodeGen/Externs.hs
index c77b824..74617a1 100644
--- a/src/Language/PureScript/CodeGen/Externs.hs
+++ b/src/Language/PureScript/CodeGen/Externs.hs
@@ -24,10 +24,10 @@ import qualified Data.Map as M
import Control.Monad.Writer
+import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Declarations
import Language.PureScript.Pretty
import Language.PureScript.Names
-import Language.PureScript.Values
import Language.PureScript.Environment
-- |
diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs
index b224ea9..c40f3f6 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -30,7 +30,6 @@ import Control.Monad (replicateM, forM)
import qualified Data.Map as M
-import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Scope
import Language.PureScript.Declarations
@@ -134,6 +133,7 @@ valueToJs opts m e (Case values binders) = bindersToJs opts m e binders (map (va
valueToJs opts m e (IfThenElse cond th el) = JSConditional (valueToJs opts m e cond) (valueToJs opts m e th) (valueToJs opts m e el)
valueToJs opts m e (Accessor prop val) = JSAccessor prop (valueToJs opts m e val)
valueToJs opts m e (App val arg) = JSApp (valueToJs opts m e val) [valueToJs opts m e arg]
+valueToJs opts m e (Let ds val) = JSApp (JSFunction Nothing [] (JSBlock (concat (mapMaybe (flip (declToJs opts m) e) ds) ++ [JSReturn $ valueToJs opts m e val]))) []
valueToJs opts m e (Abs (Left arg) val) = JSFunction Nothing [identToJs arg] (JSBlock [JSReturn (valueToJs opts m (bindName m arg e) val)])
valueToJs opts m e (TypedValue _ (Abs (Left arg) val) ty) | optionsPerformRuntimeTypeChecks opts = let arg' = identToJs arg in JSFunction Nothing [arg'] (JSBlock $ runtimeTypeChecks arg' ty ++ [JSReturn (valueToJs opts m e val)])
valueToJs _ m _ (Var ident) = varToJs m ident
@@ -193,7 +193,7 @@ runtimeTypeChecks arg ty =
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 (Object row) =
+ argumentCheck val (TypeApp t row) | t == tyObject =
let
(pairs, _) = rowToList row
in
diff --git a/src/Language/PureScript/DeadCodeElimination.hs b/src/Language/PureScript/DeadCodeElimination.hs
index 15889e7..c20781a 100644
--- a/src/Language/PureScript/DeadCodeElimination.hs
+++ b/src/Language/PureScript/DeadCodeElimination.hs
@@ -23,7 +23,6 @@ import Data.Generics
import Data.Maybe (mapMaybe)
import Language.PureScript.Names
-import Language.PureScript.Values
import Language.PureScript.Declarations
-- |
diff --git a/src/Language/PureScript/Declarations.hs b/src/Language/PureScript/Declarations.hs
index 1410f5f..6dc5d3c 100644
--- a/src/Language/PureScript/Declarations.hs
+++ b/src/Language/PureScript/Declarations.hs
@@ -16,14 +16,15 @@
module Language.PureScript.Declarations where
-import Language.PureScript.Values
import Language.PureScript.Types
import Language.PureScript.Names
import Language.PureScript.Kinds
+import Language.PureScript.TypeClassDictionaries
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
import qualified Data.Data as D
+import Data.Generics (mkQ, everything)
-- |
-- A precedence level for an infix operator
@@ -33,11 +34,12 @@ type Precedence = Integer
-- |
-- Associativity for infix operators
--
-data Associativity = Infixl | Infixr deriving (D.Data, D.Typeable)
+data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable)
instance Show Associativity where
show Infixl = "infixl"
show Infixr = "infixr"
+ show Infix = "infix"
-- |
-- Fixity data for infix operators
@@ -189,3 +191,193 @@ isTypeClassDeclaration :: Declaration -> Bool
isTypeClassDeclaration TypeClassDeclaration{} = True
isTypeClassDeclaration TypeInstanceDeclaration{} = True
isTypeClassDeclaration _ = False
+
+-- |
+-- A guard is just a boolean-valued expression that appears alongside a set of binders
+--
+type Guard = Value
+
+-- |
+-- Data type for values
+--
+data Value
+ -- |
+ -- A numeric literal
+ --
+ = NumericLiteral (Either Integer Double)
+ -- |
+ -- A string literal
+ --
+ | StringLiteral String
+ -- |
+ -- A boolean literal
+ --
+ | BooleanLiteral Bool
+ -- |
+ -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
+ -- will be removed.
+ --
+ | BinaryNoParens (Qualified Ident) Value Value
+ -- |
+ -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
+ -- will be removed.
+ --
+ | Parens Value
+ -- |
+ -- An array literal
+ --
+ | ArrayLiteral [Value]
+ -- |
+ -- An object literal
+ --
+ | ObjectLiteral [(String, Value)]
+ -- |
+ -- An record property accessor expression
+ --
+ | Accessor String Value
+ -- |
+ -- Partial record update
+ --
+ | ObjectUpdate Value [(String, Value)]
+ -- |
+ -- Function introduction
+ --
+ | Abs (Either Ident Binder) Value
+ -- |
+ -- Function application
+ --
+ | App Value Value
+ -- |
+ -- Variable
+ --
+ | Var (Qualified Ident)
+ -- |
+ -- Conditional (if-then-else expression)
+ --
+ | IfThenElse Value Value Value
+ -- |
+ -- A data constructor
+ --
+ | Constructor (Qualified ProperName)
+ -- |
+ -- A case expression. During the case expansion phase of desugaring, top-level binders will get
+ -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
+ --
+ | Case [Value] [CaseAlternative]
+ -- |
+ -- A value with a type annotation
+ --
+ | TypedValue Bool Value Type
+ -- |
+ -- A let binding
+ --
+ | Let [Declaration] Value
+ -- |
+ -- A do-notation block
+ --
+ | Do [DoNotationElement]
+ -- |
+ -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
+ -- placeholders will be replaced with actual expressions representing type classes dictionaries which
+ -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and
+ -- instance type, and the type class dictionaries in scope.
+ --
+ | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, D.Data, D.Typeable)
+
+-- |
+-- An alternative in a case statement
+--
+data CaseAlternative = CaseAlternative
+ { -- |
+ -- A collection of binders with which to match the inputs
+ --
+ caseAlternativeBinders :: [Binder]
+ -- |
+ -- An optional guard
+ --
+ , caseAlternativeGuard :: Maybe Guard
+ -- |
+ -- The result expression
+ --
+ , caseAlternativeResult :: Value
+ } deriving (Show, D.Data, D.Typeable)
+
+-- |
+-- Find the original dictionary which a type class dictionary in scope refers to
+--
+canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
+canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
+
+-- |
+-- A statement in a do-notation block
+--
+data DoNotationElement
+ -- |
+ -- A monadic value without a binder
+ --
+ = DoNotationValue Value
+ -- |
+ -- A monadic value with a binder
+ --
+ | DoNotationBind Binder Value
+ -- |
+ -- A let statement, i.e. a pure value with a binder
+ --
+ | DoNotationLet Binder Value deriving (Show, D.Data, D.Typeable)
+
+-- |
+-- Data type for binders
+--
+data Binder
+ -- |
+ -- Wildcard binder
+ --
+ = NullBinder
+ -- |
+ -- A binder which matches a boolean literal
+ --
+ | BooleanBinder Bool
+ -- |
+ -- A binder which matches a string literal
+ --
+ | StringBinder String
+ -- |
+ -- A binder which matches a numeric literal
+ --
+ | NumberBinder (Either Integer Double)
+ -- |
+ -- A binder which binds an identifier
+ --
+ | VarBinder Ident
+ -- |
+ -- A binder which matches a data constructor
+ --
+ | ConstructorBinder (Qualified ProperName) [Binder]
+ -- |
+ -- A binder which matches a record and binds its properties
+ --
+ | ObjectBinder [(String, Binder)]
+ -- |
+ -- A binder which matches an array and binds its elements
+ --
+ | ArrayBinder [Binder]
+ -- |
+ -- A binder which matches an array and binds its head and tail
+ --
+ | ConsBinder Binder Binder
+ -- |
+ -- A binder which binds its input to an identifier
+ --
+ | NamedBinder Ident Binder deriving (Show, D.Data, D.Typeable)
+
+
+-- |
+-- Collect all names introduced in binders in an expression
+--
+binderNames :: (D.Data d) => d -> [Ident]
+binderNames = everything (++) (mkQ [] go)
+ where
+ go (VarBinder ident) = [ident]
+ go (NamedBinder ident _) = [ident]
+ go _ = []
diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs
index 0beab12..673a08d 100644
--- a/src/Language/PureScript/Environment.hs
+++ b/src/Language/PureScript/Environment.hs
@@ -21,7 +21,7 @@ import Data.Data
import Language.PureScript.Names
import Language.PureScript.Types
import Language.PureScript.Kinds
-import Language.PureScript.Values
+import Language.PureScript.TypeClassDictionaries
import qualified Language.PureScript.Constants as C
import qualified Data.Map as M
@@ -172,6 +172,12 @@ tyArray :: Type
tyArray = primTy "Array"
-- |
+-- Type constructor for objects
+--
+tyObject :: Type
+tyObject = primTy "Object"
+
+-- |
-- Smart constructor for function types
--
function :: Type -> Type -> Type
@@ -183,6 +189,7 @@ function t1 = TypeApp (TypeApp tyFunction t1)
primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
, (primName "Array" , (FunKind Star Star, ExternData))
+ , (primName "Object" , (FunKind (Row Star) Star, ExternData))
, (primName "String" , (Star, ExternData))
, (primName "Number" , (Star, ExternData))
, (primName "Boolean" , (Star, ExternData)) ]
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 9f4a148..00a857a 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -67,4 +67,4 @@ getModuleName (Module mn _ _) = mn
toModule :: SCC Module -> Either String Module
toModule (AcyclicSCC m) = return m
toModule (CyclicSCC [m]) = return m
-toModule (CyclicSCC _) = Left "Cycle in module dependencies"
+toModule (CyclicSCC ms) = Left $ "Cycle in module dependencies: " ++ show (map getModuleName ms)
diff --git a/src/Language/PureScript/Optimizer/MagicDo.hs b/src/Language/PureScript/Optimizer/MagicDo.hs
index e83bdfb..1e3d9ed 100644
--- a/src/Language/PureScript/Optimizer/MagicDo.hs
+++ b/src/Language/PureScript/Optimizer/MagicDo.hs
@@ -30,8 +30,8 @@ import Language.PureScript.Names
import qualified Language.PureScript.Constants as C
magicDo :: Options -> JS -> JS
-magicDo opts | optionsMagicDo opts = inlineST . magicDo'
- | otherwise = id
+magicDo opts | optionsNoMagicDo opts = id
+ | otherwise = inlineST . magicDo'
-- |
-- Inline type class dictionaries for >>= and return for the Eff monad
@@ -58,12 +58,14 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
convert :: JS -> JS
-- Desugar return
convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
- -- Desugae >>
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock [JSReturn ret])]) | isBind bind =
- JSFunction (Just fnName) [] $ JSBlock [ JSApp m [], JSReturn (JSApp ret []) ]
+ -- Desugar >>
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing ["_"] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
+ let JSReturn ret = last js in
+ JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : init js ++ [JSReturn (JSApp ret [])] )
-- Desugar >>=
- convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock [JSReturn ret])]) | isBind bind =
- JSFunction (Just fnName) [] $ JSBlock [ JSVariableIntroduction arg (Just (JSApp m [])), JSReturn (JSApp ret []) ]
+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind && isJSReturn (last js) =
+ let JSReturn ret = last js in
+ JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : init js ++ [JSReturn (JSApp ret [])] )
-- Desugar untilE
convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =
JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn (JSObjectLiteral []) ])) []
@@ -109,6 +111,9 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
undo other = other
+ isJSReturn (JSReturn _) = True
+ isJSReturn _ = False
+
-- |
-- Inline functions in the ST module
--
@@ -128,8 +133,8 @@ inlineST = everywhere (mkT convertBlock)
-- Convert a block in a safe way, preserving object wrappers of references,
-- or in a more aggressive way, turning wrappers into local variables depending on the
-- agg(ressive) parameter.
- convert agg (JSApp (JSApp f [arg]) []) | isSTFunc C.newSTRef f =
- if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]
+ convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =
+ JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])
convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =
if agg then ref else JSAccessor C.stRefValue ref
convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
diff --git a/src/Language/PureScript/Optimizer/TCO.hs b/src/Language/PureScript/Optimizer/TCO.hs
index e29f230..a7ea0ba 100644
--- a/src/Language/PureScript/Optimizer/TCO.hs
+++ b/src/Language/PureScript/Optimizer/TCO.hs
@@ -24,8 +24,8 @@ import Language.PureScript.CodeGen.JS.AST
-- Eliminate tail calls
--
tco :: Options -> JS -> JS
-tco opts | optionsTco opts = tco'
- | otherwise = id
+tco opts | optionsNoTco opts = id
+ | otherwise = tco'
tco' :: JS -> JS
tco' = everywhere (mkT convert)
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index d701d70..e4eaf18 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -20,17 +20,21 @@ module Language.PureScript.Options where
--
data Options = Options {
-- |
- -- Perform tail-call elimination
+ -- Disable inclusion of the built in Prelude
--
- optionsTco :: Bool
+ optionsNoPrelude :: Bool
+ -- |
+ -- Disable tail-call elimination
+ --
+ , optionsNoTco :: Bool
-- |
-- Perform type checks at runtime
--
, optionsPerformRuntimeTypeChecks :: Bool
-- |
- -- Inline calls to ret and bind for the Eff monad
+ -- Disable inlining of calls to return and bind for the Eff monad
--
- , optionsMagicDo :: Bool
+ , optionsNoMagicDo :: Bool
-- |
-- When specified, checks the type of `main` in the module, and generate a call to run main
-- after the module definitions.
@@ -59,4 +63,4 @@ data Options = Options {
-- Default compiler options
--
defaultOptions :: Options
-defaultOptions = Options False False False Nothing False "PS" [] []
+defaultOptions = Options False False False False Nothing False "PS" [] []
diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs
index 43fb8d4..81c1baf 100644
--- a/src/Language/PureScript/Parser.hs
+++ b/src/Language/PureScript/Parser.hs
@@ -29,7 +29,6 @@ module Language.PureScript.Parser (module P) where
import Language.PureScript.Parser.Common as P
import Language.PureScript.Parser.Types as P
-import Language.PureScript.Parser.Values as P
import Language.PureScript.Parser.State as P
import Language.PureScript.Parser.Kinds as P
import Language.PureScript.Parser.Declarations as P
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
index 810680a..49aa100 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -36,6 +36,7 @@ reservedPsNames = [ "data"
, "import"
, "infixl"
, "infixr"
+ , "infix"
, "class"
, "instance"
, "module"
@@ -226,8 +227,14 @@ parseQualified parser = part []
-- Parse an integer or floating point value
--
integerOrFloat :: P.Parsec String u (Either Integer Double)
-integerOrFloat = (Right <$> P.try (PT.float tokenParser) <|>
- Left <$> P.try (PT.natural tokenParser)) P.<?> "number"
+integerOrFloat = (Right <$> P.try (signed PT.float) <|>
+ Left <$> P.try (signed PT.natural)) P.<?> "number"
+ where
+ signed p = do
+ let sign = (P.char '-' >> return negate) <|> (optional (P.char '+') >> return id)
+ f <- sign
+ n <- p tokenParser
+ return (f n)
-- |
-- Parse an identifier or parenthesized operator
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
index 0b011eb..3e3138b 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -16,22 +16,28 @@
module Language.PureScript.Parser.Declarations (
parseDeclaration,
parseModule,
- parseModules
+ parseModules,
+ parseValue,
+ parseGuard,
+ parseBinder,
+ parseBinderNoParens,
) where
import Data.Maybe (isJust, fromMaybe)
import Control.Applicative
-import qualified Text.Parsec as P
import Language.PureScript.Parser.State
import Language.PureScript.Parser.Common
import Language.PureScript.Declarations
-import Language.PureScript.Parser.Values
import Language.PureScript.Parser.Types
import Language.PureScript.Parser.Kinds
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Environment
+import qualified Language.PureScript.Parser.Common as C
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Expr as P
+
parseDataDeclaration :: P.Parsec String ParseState Declaration
parseDataDeclaration = do
reserved "data"
@@ -54,12 +60,17 @@ parseTypeSynonymDeclaration =
<*> (lexeme (indented *> P.char '=') *> parsePolyType)
parseValueDeclaration :: P.Parsec String ParseState Declaration
-parseValueDeclaration =
- ValueDeclaration <$> parseIdent
- <*> pure Value
- <*> P.many parseBinderNoParens
- <*> P.optionMaybe parseGuard
- <*> (lexeme (indented *> P.char '=') *> parseValue)
+parseValueDeclaration = do
+ name <- parseIdent
+ binders <- P.many parseBinderNoParens
+ guard <- P.optionMaybe parseGuard
+ value <- lexeme (indented *> P.char '=') *> parseValue
+ whereClause <- P.optionMaybe $ do
+ C.indented
+ reserved "where"
+ C.indented
+ C.mark $ P.many1 (C.same *> parseLocalDeclaration)
+ return $ ValueDeclaration name Value binders guard (maybe value (`Let` value) whereClause)
parseExternDeclaration :: P.Parsec String ParseState Declaration
parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
@@ -83,7 +94,8 @@ parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "imp
parseAssociativity :: P.Parsec String ParseState Associativity
parseAssociativity =
(P.try (reserved "infixl") >> return Infixl) <|>
- (P.try (reserved "infixr") >> return Infixr)
+ (P.try (reserved "infixr") >> return Infixr) <|>
+ (P.try (reserved "infix") >> return Infix)
parseFixity :: P.Parsec String ParseState Fixity
parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
@@ -159,7 +171,14 @@ parseDeclaration = P.choice
, parseFixityDeclaration
, parseImportDeclaration
, parseTypeClassDeclaration
- , parseTypeInstanceDeclaration ] P.<?> "declaration"
+ , parseTypeInstanceDeclaration
+ ] P.<?> "declaration"
+
+parseLocalDeclaration :: P.Parsec String ParseState Declaration
+parseLocalDeclaration = P.choice
+ [ parseTypeDeclaration
+ , parseValueDeclaration
+ ] P.<?> "local declaration"
-- |
-- Parse a module header and a collection of declarations
@@ -179,3 +198,213 @@ parseModule = do
--
parseModules :: P.Parsec String ParseState [Module]
parseModules = whiteSpace *> mark (P.many (same *> parseModule)) <* P.eof
+
+booleanLiteral :: P.Parsec String ParseState Bool
+booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
+
+parseNumericLiteral :: P.Parsec String ParseState Value
+parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
+
+parseStringLiteral :: P.Parsec String ParseState Value
+parseStringLiteral = StringLiteral <$> C.stringLiteral
+
+parseBooleanLiteral :: P.Parsec String ParseState Value
+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
+
+parseArrayLiteral :: P.Parsec String ParseState Value
+parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
+
+parseObjectLiteral :: P.Parsec String ParseState Value
+parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
+
+parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
+parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
+ <*> (C.indented *> parseValue)
+
+parseAbs :: P.Parsec String ParseState Value
+parseAbs = do
+ C.reservedOp "\\"
+ args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
+ C.indented *> C.reservedOp "->"
+ value <- parseValue
+ return $ toFunction args value
+ where
+ toFunction :: [Value -> Value] -> Value -> Value
+ toFunction args value = foldr ($) value args
+
+parseVar :: P.Parsec String ParseState Value
+parseVar = Var <$> C.parseQualified C.parseIdent
+
+parseConstructor :: P.Parsec String ParseState Value
+parseConstructor = Constructor <$> C.parseQualified C.properName
+
+parseCase :: P.Parsec String ParseState Value
+parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
+
+parseCaseAlternative :: P.Parsec String ParseState CaseAlternative
+parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
+ <*> P.optionMaybe parseGuard
+ <*> (C.indented *> C.reservedOp "->" *> parseValue)
+ P.<?> "case alternative"
+
+parseIfThenElse :: P.Parsec String ParseState Value
+parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
+ <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
+ <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
+
+parseLet :: P.Parsec String ParseState Value
+parseLet = do
+ C.reserved "let"
+ C.indented
+ ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
+ C.indented
+ C.reserved "in"
+ result <- parseValue
+ return $ Let ds result
+
+parseValueAtom :: P.Parsec String ParseState Value
+parseValueAtom = P.choice
+ [ P.try parseNumericLiteral
+ , P.try parseStringLiteral
+ , P.try parseBooleanLiteral
+ , parseArrayLiteral
+ , P.try parseObjectLiteral
+ , parseAbs
+ , P.try parseConstructor
+ , P.try parseVar
+ , parseCase
+ , parseIfThenElse
+ , parseDo
+ , parseLet
+ , Parens <$> C.parens parseValue ]
+
+parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
+parsePropertyUpdate = do
+ name <- C.lexeme C.identifier
+ _ <- C.lexeme $ C.indented *> P.char '='
+ value <- C.indented *> parseValue
+ return (name, value)
+
+parseAccessor :: Value -> P.Parsec String ParseState Value
+parseAccessor (Constructor _) = P.unexpected "constructor"
+parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj
+
+parseDo :: P.Parsec String ParseState Value
+parseDo = do
+ C.reserved "do"
+ C.indented
+ Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
+
+parseDoNotationLet :: P.Parsec String ParseState DoNotationElement
+parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseBinder)
+ <*> (C.indented *> C.reservedOp "=" *> parseValue)
+
+parseDoNotationBind :: P.Parsec String ParseState DoNotationElement
+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)
+
+parseDoNotationElement :: P.Parsec String ParseState DoNotationElement
+parseDoNotationElement = P.choice
+ [ P.try parseDoNotationBind
+ , parseDoNotationLet
+ , P.try (DoNotationValue <$> parseValue) ]
+
+-- |
+-- Parse a value
+--
+parseValue :: P.Parsec String ParseState Value
+parseValue =
+ (P.buildExpressionParser operators
+ . C.buildPostfixParser postfixTable2
+ $ indexersAndAccessors) P.<?> "expression"
+ where
+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
+ postfixTable1 = [ parseAccessor
+ , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
+ postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
+ , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v
+ ]
+ operators = [ [ P.Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
+ return (BinaryNoParens ident))) P.AssocRight ]
+ ]
+
+parseStringBinder :: P.Parsec String ParseState Binder
+parseStringBinder = StringBinder <$> C.stringLiteral
+
+parseBooleanBinder :: P.Parsec String ParseState Binder
+parseBooleanBinder = BooleanBinder <$> booleanLiteral
+
+parseNumberBinder :: P.Parsec String ParseState Binder
+parseNumberBinder = NumberBinder <$> C.integerOrFloat
+
+parseVarBinder :: P.Parsec String ParseState Binder
+parseVarBinder = VarBinder <$> C.parseIdent
+
+parseNullaryConstructorBinder :: P.Parsec String ParseState Binder
+parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []
+
+parseConstructorBinder :: P.Parsec String ParseState Binder
+parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)
+
+parseObjectBinder :: P.Parsec String ParseState Binder
+parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
+
+parseArrayBinder :: P.Parsec String ParseState Binder
+parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)
+
+parseNamedBinder :: P.Parsec String ParseState Binder
+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
+ <*> (C.indented *> parseBinder)
+
+parseNullBinder :: P.Parsec String ParseState Binder
+parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
+
+parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
+parseIdentifierAndBinder = do
+ name <- C.lexeme C.identifier
+ _ <- C.lexeme $ C.indented *> P.char '='
+ binder <- C.indented *> parseBinder
+ return (name, binder)
+
+-- |
+-- Parse a binder
+--
+parseBinder :: P.Parsec String ParseState Binder
+parseBinder = P.buildExpressionParser operators parseBinderAtom P.<?> "expression"
+ where
+ operators = [ [ P.Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) P.AssocRight ] ]
+ parseBinderAtom :: P.Parsec String ParseState Binder
+ parseBinderAtom = P.choice (map P.try
+ [ parseNullBinder
+ , parseStringBinder
+ , parseBooleanBinder
+ , parseNumberBinder
+ , parseNamedBinder
+ , parseVarBinder
+ , parseConstructorBinder
+ , parseObjectBinder
+ , parseArrayBinder
+ , C.parens parseBinder ]) P.<?> "binder"
+
+-- |
+-- Parse a binder as it would appear in a top level declaration
+--
+parseBinderNoParens :: P.Parsec String ParseState Binder
+parseBinderNoParens = P.choice (map P.try
+ [ parseNullBinder
+ , parseStringBinder
+ , parseBooleanBinder
+ , parseNumberBinder
+ , parseNamedBinder
+ , parseVarBinder
+ , parseNullaryConstructorBinder
+ , parseObjectBinder
+ , parseArrayBinder
+ , C.parens parseBinder ]) P.<?> "binder"
+-- |
+-- Parse a guard
+--
+parseGuard :: P.Parsec String ParseState Guard
+parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
+
+
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
index 2d584a3..a3d2c70 100644
--- a/src/Language/PureScript/Parser/Types.hs
+++ b/src/Language/PureScript/Parser/Types.hs
@@ -49,7 +49,7 @@ parseFunction :: P.Parsec String ParseState Type
parseFunction = parens $ P.try (lexeme (P.string "->")) >> return tyFunction
parseObject :: P.Parsec String ParseState Type
-parseObject = braces $ Object <$> parseRow False
+parseObject = braces $ TypeApp tyObject <$> parseRow False
parseTypeVariable :: P.Parsec String ParseState Type
parseTypeVariable = do
diff --git a/src/Language/PureScript/Parser/Values.hs b/src/Language/PureScript/Parser/Values.hs
deleted file mode 100644
index f148ed5..0000000
--- a/src/Language/PureScript/Parser/Values.hs
+++ /dev/null
@@ -1,246 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Parser.Values
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Parsers for values, statements, binders and guards
---
------------------------------------------------------------------------------
-
-module Language.PureScript.Parser.Values (
- parseValue,
- parseGuard,
- parseBinder,
- parseBinderNoParens,
-) where
-
-import Control.Applicative
-
-import Language.PureScript.Values
-import Language.PureScript.Parser.State
-import Language.PureScript.Parser.Types
-
-import Text.Parsec.Expr
-
-import qualified Language.PureScript.Parser.Common as C
-import qualified Text.Parsec as P
-
-booleanLiteral :: P.Parsec String ParseState Bool
-booleanLiteral = (C.reserved "true" >> return True) P.<|> (C.reserved "false" >> return False)
-
-parseNumericLiteral :: P.Parsec String ParseState Value
-parseNumericLiteral = NumericLiteral <$> C.integerOrFloat
-
-parseStringLiteral :: P.Parsec String ParseState Value
-parseStringLiteral = StringLiteral <$> C.stringLiteral
-
-parseBooleanLiteral :: P.Parsec String ParseState Value
-parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
-
-parseArrayLiteral :: P.Parsec String ParseState Value
-parseArrayLiteral = ArrayLiteral <$> C.squares (C.commaSep parseValue)
-
-parseObjectLiteral :: P.Parsec String ParseState Value
-parseObjectLiteral = ObjectLiteral <$> C.braces (C.commaSep parseIdentifierAndValue)
-
-parseIdentifierAndValue :: P.Parsec String ParseState (String, Value)
-parseIdentifierAndValue = (,) <$> (C.indented *> C.identifier <* C.indented <* C.colon)
- <*> (C.indented *> parseValue)
-
-parseAbs :: P.Parsec String ParseState Value
-parseAbs = do
- C.reservedOp "\\"
- args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
- C.indented *> C.reservedOp "->"
- value <- parseValue
- return $ toFunction args value
- where
- toFunction :: [Value -> Value] -> Value -> Value
- toFunction args value = foldr ($) value args
-
-parseVar :: P.Parsec String ParseState Value
-parseVar = Var <$> C.parseQualified C.parseIdent
-
-parseConstructor :: P.Parsec String ParseState Value
-parseConstructor = Constructor <$> C.parseQualified C.properName
-
-parseCase :: P.Parsec String ParseState Value
-parseCase = Case <$> P.between (P.try (C.reserved "case")) (C.indented *> C.reserved "of") (return <$> parseValue)
- <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
-
-parseCaseAlternative :: P.Parsec String ParseState CaseAlternative
-parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
- <*> P.optionMaybe parseGuard
- <*> (C.indented *> C.reservedOp "->" *> parseValue)
- P.<?> "case alternative"
-
-parseIfThenElse :: P.Parsec String ParseState Value
-parseIfThenElse = IfThenElse <$> (P.try (C.reserved "if") *> C.indented *> parseValue)
- <*> (C.indented *> C.reserved "then" *> C.indented *> parseValue)
- <*> (C.indented *> C.reserved "else" *> C.indented *> parseValue)
-
-parseLet :: P.Parsec String ParseState Value
-parseLet = do
- C.reserved "let"
- C.indented
- binder <- P.try (Right <$> ((,) <$> C.parseIdent <*> P.many (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
- <|> (Left <$> parseBinder)
- C.indented
- C.reservedOp "="
- C.indented
- value <- parseValue
- C.indented
- C.reserved "in"
- result <- parseValue
- return $ Let binder value result
-
-parseValueAtom :: P.Parsec String ParseState Value
-parseValueAtom = P.choice
- [ P.try parseNumericLiteral
- , P.try parseStringLiteral
- , P.try parseBooleanLiteral
- , parseArrayLiteral
- , P.try parseObjectLiteral
- , parseAbs
- , P.try parseConstructor
- , P.try parseVar
- , parseCase
- , parseIfThenElse
- , parseDo
- , parseLet
- , Parens <$> C.parens parseValue ]
-
-parsePropertyUpdate :: P.Parsec String ParseState (String, Value)
-parsePropertyUpdate = do
- name <- C.lexeme C.identifier
- _ <- C.lexeme $ C.indented *> P.char '='
- value <- C.indented *> parseValue
- return (name, value)
-
-parseAccessor :: Value -> P.Parsec String ParseState Value
-parseAccessor (Constructor _) = P.unexpected "constructor"
-parseAccessor obj = P.try $ Accessor <$> (C.indented *> C.dot *> P.notFollowedBy C.opLetter *> C.indented *> C.identifier) <*> pure obj
-
-parseDo :: P.Parsec String ParseState Value
-parseDo = do
- C.reserved "do"
- C.indented
- Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
-
-parseDoNotationLet :: P.Parsec String ParseState DoNotationElement
-parseDoNotationLet = DoNotationLet <$> (C.reserved "let" *> C.indented *> parseBinder)
- <*> (C.indented *> C.reservedOp "=" *> parseValue)
-
-parseDoNotationBind :: P.Parsec String ParseState DoNotationElement
-parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> C.reservedOp "<-" *> parseValue)
-
-parseDoNotationElement :: P.Parsec String ParseState DoNotationElement
-parseDoNotationElement = P.choice
- [ P.try parseDoNotationBind
- , parseDoNotationLet
- , P.try (DoNotationValue <$> parseValue) ]
-
--- |
--- Parse a value
---
-parseValue :: P.Parsec String ParseState Value
-parseValue =
- (buildExpressionParser operators
- . C.buildPostfixParser postfixTable2
- $ indexersAndAccessors) P.<?> "expression"
- where
- indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
- postfixTable1 = [ parseAccessor
- , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> C.braces (C.commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
- postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
- , \v -> flip (TypedValue True) <$> (P.try (C.lexeme (C.indented *> P.string "::")) *> parsePolyType) <*> pure v
- ]
- operators = [ [ Infix (C.lexeme (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
- return (BinaryNoParens ident))) AssocRight ]
- ]
-
-parseStringBinder :: P.Parsec String ParseState Binder
-parseStringBinder = StringBinder <$> C.stringLiteral
-
-parseBooleanBinder :: P.Parsec String ParseState Binder
-parseBooleanBinder = BooleanBinder <$> booleanLiteral
-
-parseNumberBinder :: P.Parsec String ParseState Binder
-parseNumberBinder = NumberBinder <$> C.integerOrFloat
-
-parseVarBinder :: P.Parsec String ParseState Binder
-parseVarBinder = VarBinder <$> C.parseIdent
-
-parseNullaryConstructorBinder :: P.Parsec String ParseState Binder
-parseNullaryConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> pure []
-
-parseConstructorBinder :: P.Parsec String ParseState Binder
-parseConstructorBinder = ConstructorBinder <$> C.lexeme (C.parseQualified C.properName) <*> many (C.indented *> parseBinderNoParens)
-
-parseObjectBinder :: P.Parsec String ParseState Binder
-parseObjectBinder = ObjectBinder <$> C.braces (C.commaSep (C.indented *> parseIdentifierAndBinder))
-
-parseArrayBinder :: P.Parsec String ParseState Binder
-parseArrayBinder = C.squares $ ArrayBinder <$> C.commaSep (C.indented *> parseBinder)
-
-parseNamedBinder :: P.Parsec String ParseState Binder
-parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* C.lexeme (P.char '@'))
- <*> (C.indented *> parseBinder)
-
-parseNullBinder :: P.Parsec String ParseState Binder
-parseNullBinder = C.lexeme (P.char '_') *> P.notFollowedBy C.identLetter *> return NullBinder
-
-parseIdentifierAndBinder :: P.Parsec String ParseState (String, Binder)
-parseIdentifierAndBinder = do
- name <- C.lexeme C.identifier
- _ <- C.lexeme $ C.indented *> P.char '='
- binder <- C.indented *> parseBinder
- return (name, binder)
-
--- |
--- Parse a binder
---
-parseBinder :: P.Parsec String ParseState Binder
-parseBinder = buildExpressionParser operators parseBinderAtom P.<?> "expression"
- where
- operators = [ [ Infix ( C.lexeme (P.try $ C.indented *> C.reservedOp ":") >> return ConsBinder) AssocRight ] ]
- parseBinderAtom :: P.Parsec String ParseState Binder
- parseBinderAtom = P.choice (map P.try
- [ parseNullBinder
- , parseStringBinder
- , parseBooleanBinder
- , parseNumberBinder
- , parseNamedBinder
- , parseVarBinder
- , parseConstructorBinder
- , parseObjectBinder
- , parseArrayBinder
- , C.parens parseBinder ]) P.<?> "binder"
-
--- |
--- Parse a binder as it would appear in a top level declaration
---
-parseBinderNoParens :: P.Parsec String ParseState Binder
-parseBinderNoParens = P.choice (map P.try
- [ parseNullBinder
- , parseStringBinder
- , parseBooleanBinder
- , parseNumberBinder
- , parseNamedBinder
- , parseVarBinder
- , parseNullaryConstructorBinder
- , parseObjectBinder
- , parseArrayBinder
- , C.parens parseBinder ]) P.<?> "binder"
--- |
--- Parse a guard
---
-parseGuard :: P.Parsec String ParseState Guard
-parseGuard = C.indented *> C.pipe *> C.indented *> parseValue
-
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 964398c..b55f44c 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -34,8 +34,8 @@ import Language.PureScript.Environment
typeLiterals :: Pattern () Type String
typeLiterals = mkPattern match
where
- match (Object row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
match (TypeVar var) = Just var
+ match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
match (TypeConstructor ctor) = Just $ show ctor
match (TUnknown (Unknown u)) = Just $ 'u' : show u
@@ -56,10 +56,7 @@ prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs
nameAndTypeToPs name ty = name ++ " :: " ++ prettyPrintType ty
tailToPs :: Type -> String
tailToPs REmpty = ""
- tailToPs (TUnknown (Unknown u)) = " | u" ++ show u
- tailToPs (TypeVar var) = " | " ++ var
- tailToPs (Skolem s _) = " | s" ++ show s
- tailToPs _ = error "Invalid row tail"
+ tailToPs other = " | " ++ prettyPrintType other
toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
toList tys (RCons name ty row) = toList ((name, ty):tys) row
toList tys r = (tys, r)
@@ -81,6 +78,7 @@ insertPlaceholders = everywhere' (mkT convertForAlls) . everywhere (mkT convert)
where
convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
+ convert (TypeApp o r) | o == tyObject = PrettyPrintObject r
convert other = other
convertForAlls (ForAll ident ty _) = go [ident] ty
where
diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs
index 39fd6e0..c0007bd 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -24,7 +24,7 @@ import Control.Arrow ((<+>))
import Control.PatternArrows
import Language.PureScript.Types
-import Language.PureScript.Values
+import Language.PureScript.Declarations
import Language.PureScript.Pretty.Common
import Language.PureScript.Pretty.Types
@@ -40,6 +40,7 @@ literals = mkPattern match
match (Constructor name) = Just $ show name
match (Case values binders) = Just $ "case " ++ unwords (map prettyPrintValue values) ++
" of { " ++ intercalate " ; " (map prettyPrintCaseAlternative binders) ++ " }"
+ match (Let _ val) = Just $ "let ... in " ++ prettyPrintValue val
match (Var ident) = Just $ show ident
match (Do els) = Just $ " do { " ++ intercalate "; " (map prettyPrintDoNotationElement els) ++ " }"
match (TypeClassDictionary _ _) = error "Type class dictionary was not replaced"
diff --git a/src/Language/PureScript/Scope.hs b/src/Language/PureScript/Scope.hs
index 043552f..fea0e65 100644
--- a/src/Language/PureScript/Scope.hs
+++ b/src/Language/PureScript/Scope.hs
@@ -24,7 +24,7 @@ import Data.Data
import Data.List ((\\), nub)
import Data.Generics (extQ, mkQ, everything)
-import Language.PureScript.Values
+import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.CodeGen.JS.AST
diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs
index 2aa7af9..3f0f228 100644
--- a/src/Language/PureScript/Sugar.hs
+++ b/src/Language/PureScript/Sugar.hs
@@ -16,7 +16,6 @@
module Language.PureScript.Sugar (desugar, module S) where
import Control.Monad
-import Control.Arrow ((>>>))
import Language.PureScript.Declarations
@@ -26,14 +25,11 @@ import Language.PureScript.Sugar.CaseDeclarations as S
import Language.PureScript.Sugar.TypeDeclarations as S
import Language.PureScript.Sugar.BindingGroups as S
import Language.PureScript.Sugar.TypeClasses as S
-import Language.PureScript.Sugar.Let as S
import Language.PureScript.Sugar.Names as S
-- |
-- The desugaring pipeline proceeds as follows:
--
--- * Desugar let bindings
---
-- * Introduce type synonyms for type class dictionaries
--
-- * Rebracket user-defined binary operators
@@ -50,10 +46,9 @@ import Language.PureScript.Sugar.Names as S
--
desugar :: [Module] -> Either String [Module]
desugar = desugarDo
- >=> desugarLetBindings
- >>> desugarCasesModule
+ >=> desugarCasesModule
+ >=> desugarTypeDeclarationsModule
>=> desugarImports
>=> rebracket
- >=> desugarTypeDeclarationsModule
>=> desugarTypeClasses
>=> createBindingGroupsModule
diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs
index c695dcd..9f60af4 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -24,13 +24,13 @@ module Language.PureScript.Sugar.BindingGroups (
import Data.Data
import Data.Graph
import Data.Generics
+import Data.Generics.Extras
import Data.List (nub, intersect)
import Data.Maybe (mapMaybe)
import Control.Applicative ((<$>), (<*>), pure)
import Language.PureScript.Declarations
import Language.PureScript.Names
-import Language.PureScript.Values
import Language.PureScript.Types
import Language.PureScript.Environment
@@ -51,8 +51,8 @@ collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (colla
--
createBindingGroups :: ModuleName -> [Declaration] -> Either String [Declaration]
createBindingGroups moduleName ds = do
- let values = filter isValueDecl ds
- dataDecls = filter isDataDecl ds
+ values <- mapM (createBindingGroupsForValue moduleName) $ filter isValueDecl ds
+ let dataDecls = filter isDataDecl ds
allProperNames = map getProperName dataDecls
dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
dataBindingGroupDecls <- mapM toDataBindingGroup $ stronglyConnComp dataVerts
@@ -68,16 +68,26 @@ createBindingGroups moduleName ds = do
filter isExternDecl ds ++
bindingGroupDecls
+createBindingGroupsForValue :: ModuleName -> Declaration -> Either String Declaration
+createBindingGroupsForValue moduleName = everywhereM' (mkM go)
+ where
+ go (Let ds val) = Let <$> createBindingGroups moduleName ds <*> pure val
+ go other = return other
+
-- |
-- Collapse all binding groups to individual declarations
--
collapseBindingGroups :: [Declaration] -> [Declaration]
-collapseBindingGroups = concatMap go
+collapseBindingGroups = everywhere (mkT collapseBindingGroupsForValue) . concatMap go
where
go (DataBindingGroupDeclaration ds) = ds
go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] Nothing val) ds
go other = [other]
+collapseBindingGroupsForValue :: Value -> Value
+collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
+collapseBindingGroupsForValue other = other
+
usedIdents :: (Data d) => ModuleName -> d -> [Ident]
usedIdents moduleName = nub . everything (++) (mkQ [] usedNames)
where
diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs
index 5fe3e15..06cf071 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -20,14 +20,14 @@ module Language.PureScript.Sugar.CaseDeclarations (
) where
import Data.List (groupBy)
-import Data.Generics (mkT, everywhere)
+import Data.Generics (mkM, mkT, everywhere)
+import Data.Generics.Extras
import Control.Applicative
import Control.Monad ((<=<), forM, join, unless)
import Control.Monad.Error.Class
import Language.PureScript.Names
-import Language.PureScript.Values
import Language.PureScript.Declarations
import Language.PureScript.Scope
import Language.PureScript.Environment
@@ -57,6 +57,11 @@ desugarCases = desugarRest <=< fmap join . mapM toDecls . groupBy inSameGroup
desugarRest :: [Declaration] -> Either String [Declaration]
desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
(:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
+ desugarRest (ValueDeclaration name nameKind bs g val : rest) = do
+ (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarRest rest
+ where
+ go (Let ds val') = Let <$> desugarCases ds <*> pure val'
+ go other = return other
desugarRest (d : ds) = (:) d <$> desugarRest ds
desugarRest [] = pure []
diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs
index 07c0e37..0020b31 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -21,9 +21,9 @@ module Language.PureScript.Sugar.DoNotation (
import Data.Data
import Data.Generics
-import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Scope
+import Language.PureScript.Declarations
import qualified Language.PureScript.Constants as C
diff --git a/src/Language/PureScript/Sugar/Let.hs b/src/Language/PureScript/Sugar/Let.hs
deleted file mode 100644
index 6be289a..0000000
--- a/src/Language/PureScript/Sugar/Let.hs
+++ /dev/null
@@ -1,34 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Sugar.Let
--- Copyright : (c) Phil Freeman 2014
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- This module implements the desugaring pass which turns let bindings into function applications.
---
------------------------------------------------------------------------------
-
-module Language.PureScript.Sugar.Let (
- desugarLetBindings
-) where
-
-import Data.Generics (mkT, everywhere)
-
-import Language.PureScript.Values
-import Language.PureScript.Declarations
-
--- |
--- Turn let bindings into function applications
---
-desugarLetBindings :: [Module] -> [Module]
-desugarLetBindings = everywhere (mkT go)
- where
- go (Let (Left (VarBinder ident)) value result) = App (Abs (Left ident) result) value
- go (Let (Left binder) value result) = Case [value] [CaseAlternative [binder] Nothing result]
- go (Let (Right (ident, binders)) value result) = App (Abs (Left ident) result) (foldr Abs value binders)
- go other = other
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index d739176..3f0d7cb 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -16,6 +16,7 @@ module Language.PureScript.Sugar.Names (
desugarImports
) where
+import Data.Data
import Data.Maybe (fromMaybe, isJust)
import Data.Generics (extM, mkM, everywhereM)
import Data.Generics.Extras (mkS, extS, everywhereWithContextM')
@@ -28,7 +29,6 @@ import qualified Data.Map as M
import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
-import Language.PureScript.Values
import Language.PureScript.Environment
-- |
@@ -134,10 +134,9 @@ addExport exports name =
--
desugarImports :: [Module] -> Either String [Module]
desugarImports modules = do
- let modules' = importPrelude `map` modules
- unfilteredExports <- findExports modules'
- exports <- foldM filterModuleExports unfilteredExports modules'
- mapM (renameInModule' unfilteredExports exports) modules'
+ unfilteredExports <- findExports modules
+ exports <- foldM filterModuleExports unfilteredExports modules
+ mapM (renameInModule' unfilteredExports exports) modules
where
-- Filters the exports for a module in the global exports environment so that only explicitly
@@ -157,23 +156,16 @@ desugarImports modules = do
renameInModule imports env (elaborateExports exps m)
-- |
--- Add an import declaration for the Prelude to a module if it does not already explicitly import
--- it.
+-- Rethrow an error with an extra message line prepended
--
-importPrelude :: Module -> Module
-importPrelude m@(Module mn decls exps) =
- if isPreludeImport `any` decls then m
- else Module mn (preludeImport : decls) exps
- where
- isPreludeImport (ImportDeclaration (ModuleName [ProperName "Prelude"]) _ _) = True
- isPreludeImport _ = False
- preludeImport = ImportDeclaration (ModuleName [ProperName "Prelude"]) Nothing Nothing
+rethrow :: String -> Either String a -> Either String a
+rethrow msg = flip catchError $ \e -> throwError (msg ++ ":\n" ++ e)
-- |
--- Rethrow an error with the name of the current module in the case of a failure
+-- Rethrow an error with details of the current module prepended to the message
--
rethrowForModule :: Module -> Either String a -> Either String a
-rethrowForModule (Module mn _ _) = flip catchError $ \e -> throwError ("Error in module '" ++ show mn ++ "':\n" ++ e)
+rethrowForModule (Module mn _ _) = rethrow $ "Error in module '" ++ show mn ++ "'"
-- |
-- Make all exports for a module explicit. This may still effect modules that have an exports list,
@@ -191,19 +183,25 @@ elaborateExports exps (Module mn decls _) = Module mn decls (Just $
--
renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either String Module
renameInModule imports exports (Module mn decls exps) =
- Module mn <$> (mapM updateDecl decls >>= everywhereM (mkM updateType `extM` updateValue `extM` updateBinder `extM` updateVars)) <*> pure exps
+ Module mn <$> mapM go decls <*> pure exps
where
- updateDecl (TypeInstanceDeclaration name cs cn ts ds) =
- TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts <*> pure ds
- updateDecl (ExternInstanceDeclaration name cs cn ts) =
- ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> pure ts
- updateDecl d = return d
-
- updateVars :: Declaration -> Either String Declaration
- updateVars (ValueDeclaration name nameKind [] Nothing val) =
- ValueDeclaration name nameKind [] Nothing <$> everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
+ go (DataDeclaration name args dctors) =
+ rethrowFor "data declaration" name $ DataDeclaration <$> pure name <*> pure args <*> updateAll dctors
+ go (DataBindingGroupDeclaration decls') =
+ DataBindingGroupDeclaration <$> mapM go decls'
+ go (TypeSynonymDeclaration name ps ty) =
+ rethrowFor "type synonym" name $ TypeSynonymDeclaration <$> pure name <*> pure ps <*> updateType' ty
+ go (TypeInstanceDeclaration name cs cn ts ds) =
+ TypeInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts <*> mapM go ds
+ go (ExternInstanceDeclaration name cs cn ts) =
+ ExternInstanceDeclaration name <$> updateConstraints cs <*> updateClassName cn <*> updateType' ts
+ go (ValueDeclaration name nameKind [] Nothing val) = do
+ val' <- everywhereWithContextM' [] (mkS bindFunctionArgs `extS` bindBinders) val
+ rethrowFor "declaration" name $ ValueDeclaration name nameKind [] Nothing <$> updateAll val'
where
bindFunctionArgs bound (Abs (Left arg) val') = return (arg : bound, Abs (Left arg) val')
+ bindFunctionArgs bound (Let ds val') = let args = map letBoundVariable ds in
+ return (args ++ bound, Let ds val')
bindFunctionArgs bound (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
(,) bound <$> (Var <$> updateValueName name')
bindFunctionArgs bound (Var name'@(Qualified (Just _) _)) =
@@ -215,16 +213,37 @@ renameInModule imports exports (Module mn decls exps) =
bindFunctionArgs bound other = return (bound, other)
bindBinders :: [Ident] -> CaseAlternative -> Either String ([Ident], CaseAlternative)
bindBinders bound c@(CaseAlternative bs _ _) = return (binderNames bs ++ bound, c)
- updateVars (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name
- updateVars other = return other
+
+ letBoundVariable :: Declaration -> Ident
+ letBoundVariable (ValueDeclaration ident _ _ _ _) = ident
+ letBoundVariable _ = error "Invalid argument to letBoundVariable"
+ go (ValueDeclaration name _ _ _ _) = error $ "Binders should have been desugared in " ++ show name
+ go (ExternDeclaration fit name js ty) =
+ rethrowFor "declaration" name $ ExternDeclaration <$> pure fit <*> pure name <*> pure js <*> updateType' ty
+ go (BindingGroupDeclaration decls') = do
+ BindingGroupDeclaration <$> mapM go' decls'
+ where go' = \(name, nk, value) -> rethrowFor "declaration" name $ (,,) <$> pure name <*> pure nk <*> updateAll value
+ go d = updateAll d
+
+ rethrowFor :: (Show a) => String -> a -> Either String b -> Either String b
+ rethrowFor what name = rethrow $ "Error in " ++ what ++ " '" ++ show name ++ "'"
+
+ updateAll :: Data d => d -> Either String d
+ updateAll = everywhereM (mkM updateType `extM` updateValue `extM` updateBinder)
+
updateValue (Constructor name) = Constructor <$> updateDataConstructorName name
updateValue v = return v
+
updateBinder (ConstructorBinder name b) = ConstructorBinder <$> updateDataConstructorName name <*> pure b
updateBinder v = return v
+
updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name
updateType (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name <*> mapM updateType tys
updateType (ConstrainedType cs t) = ConstrainedType <$> updateConstraints cs <*> pure t
updateType t = return t
+ updateType' :: Data d => d -> Either String d
+ updateType' = everywhereM (mkM updateType)
+
updateConstraints = mapM (\(name, ts) -> (,) <$> updateClassName name <*> pure ts)
updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` (exportedTypes mes)))
diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs
index 6252c92..d0a3fc5 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -25,7 +25,6 @@ module Language.PureScript.Sugar.Operators (
import Language.PureScript.Names
import Language.PureScript.Declarations
-import Language.PureScript.Values
import Control.Applicative
import Control.Monad.State
@@ -107,6 +106,7 @@ matchOperators ops = parseChains
toAssoc :: Associativity -> P.Assoc
toAssoc Infixl = P.AssocLeft
toAssoc Infixr = P.AssocRight
+toAssoc Infix = P.AssocNone
token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
token = P.token show (const (P.initialPos ""))
diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs
index 51b63ee..67c35b0 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -22,7 +22,6 @@ module Language.PureScript.Sugar.TypeClasses (
import Language.PureScript.Declarations
import Language.PureScript.Names
import Language.PureScript.Types
-import Language.PureScript.Values
import Language.PureScript.CodeGen.JS.AST
import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Environment
@@ -108,7 +107,7 @@ memberToNameAndType _ = error "Invalid declaration in type class definition"
typeClassDictionaryDeclaration :: ProperName -> [String] -> [Declaration] -> Declaration
typeClassDictionaryDeclaration name args members =
- TypeSynonymDeclaration name args (Object $ rowFromList (map memberToNameAndType members, REmpty))
+ TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (map memberToNameAndType members, REmpty))
typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [String] -> Declaration -> Declaration
typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
@@ -134,6 +133,9 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls = do
foldr (function . (\(pn, tys') -> foldl TypeApp (TypeConstructor pn) tys')) (foldl TypeApp (TypeConstructor className) tys) deps))
)
where
+ unit :: Type
+ unit = TypeApp tyObject REmpty
+
memberToNameAndValue :: [(String, Type)] -> Declaration -> Desugar (String, Value)
memberToNameAndValue tys' (ValueDeclaration ident _ _ _ _) = do
memberType <- lift . maybe (Left "Type class member type not found") Right $ lookup (identToJs ident) tys'
diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs
index df72385..262f72e 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -19,12 +19,14 @@ module Language.PureScript.Sugar.TypeDeclarations (
desugarTypeDeclarationsModule
) where
+import Data.Generics (mkM)
+import Data.Generics.Extras
+
import Control.Applicative
import Control.Monad.Error.Class
import Control.Monad (forM)
import Language.PureScript.Declarations
-import Language.PureScript.Values
-- |
-- Replace all top level type declarations in a module with type annotations
@@ -39,5 +41,10 @@ desugarTypeDeclarations :: [Declaration] -> Either String [Declaration]
desugarTypeDeclarations (TypeDeclaration name ty : ValueDeclaration name' nameKind [] Nothing val : rest) | name == name' =
desugarTypeDeclarations (ValueDeclaration name nameKind [] Nothing (TypedValue True val ty) : rest)
desugarTypeDeclarations (TypeDeclaration name _ : _) = throwError $ "Orphan type declaration for " ++ show name
+desugarTypeDeclarations (ValueDeclaration name nameKind bs g val : rest) = do
+ (:) <$> (ValueDeclaration name nameKind bs g <$> everywhereM' (mkM go) val) <*> desugarTypeDeclarations rest
+ where
+ go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
+ go other = return other
desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
desugarTypeDeclarations [] = return []
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 8f26f01..e55359a 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -32,9 +32,9 @@ import Control.Monad.Error
import Language.PureScript.Types
import Language.PureScript.Names
-import Language.PureScript.Values
import Language.PureScript.Kinds
import Language.PureScript.Declarations
+import Language.PureScript.TypeClassDictionaries
import Language.PureScript.Environment
import Language.PureScript.Pretty.Types
@@ -107,7 +107,7 @@ typeCheckAll :: Maybe ModuleName -> ModuleName -> [Declaration] -> Check [Declar
typeCheckAll _ _ [] = return []
typeCheckAll mainModuleName moduleName (d@(DataDeclaration name args dctors) : rest) = do
rethrow (("Error in type constructor " ++ show name ++ ":\n") ++) $ do
- ctorKind <- kindsOf moduleName name args (concatMap snd dctors)
+ ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
addDataType moduleName name args dctors ctorKind
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
@@ -129,7 +129,7 @@ typeCheckAll mainModuleName moduleName (d@(DataBindingGroupDeclaration tys) : re
toDataDecl _ = Nothing
typeCheckAll mainModuleName moduleName (d@(TypeSynonymDeclaration name args ty) : rest) = do
rethrow (("Error in type synonym " ++ show name ++ ":\n") ++) $ do
- kind <- kindsOf moduleName name args [ty]
+ kind <- kindsOf False moduleName name args [ty]
addTypeSynonym moduleName name args ty kind
ds <- typeCheckAll mainModuleName moduleName rest
return $ d : ds
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index fbe9eaa..c8e43bf 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -67,13 +67,13 @@ kindOf _ ty =
-- |
-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
--
-kindsOf :: ModuleName -> ProperName -> [String] -> [Type] -> Check Kind
-kindsOf moduleName name args ts = fmap tidyUp . liftUnify $ do
+kindsOf :: Bool -> ModuleName -> ProperName -> [String] -> [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
bindLocalTypeVariables moduleName dict $
- solveTypes ts kargs tyCon
+ solveTypes isData ts kargs tyCon
where
tidyUp (k, sub) = starIfUnknown $ sub $? k
@@ -92,12 +92,12 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
kargs <- replicateM (length args) fresh
let argDict = zip (map ProperName args) kargs
bindLocalTypeVariables moduleName argDict $
- solveTypes ts kargs tyCon) tyCons tys
+ 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
bindLocalTypeVariables moduleName argDict $
- solveTypes [ty] kargs synVar) synVars syns
+ solveTypes False [ty] kargs synVar) synVars syns
return (syn_ks, data_ks)
where
tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . (sub $?)) ks1, map (starIfUnknown . (sub $?)) ks2)
@@ -105,11 +105,14 @@ kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
-- |
-- Solve the set of kind constraints associated with the data constructors for a type constructor
--
-solveTypes :: [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
-solveTypes ts kargs tyCon = do
+solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
+solveTypes isData ts kargs tyCon = do
ks <- mapM infer ts
- tyCon =?= foldr FunKind Star kargs
- forM_ ks $ \k -> k =?= Star
+ when isData $ do
+ tyCon =?= foldr FunKind Star kargs
+ forM_ ks $ \k -> k =?= Star
+ when (not isData) $ do
+ tyCon =?= foldr FunKind (head ks) kargs
return tyCon
-- |
@@ -117,6 +120,7 @@ solveTypes ts kargs tyCon = do
--
starIfUnknown :: Kind -> Kind
starIfUnknown (KUnknown _) = Star
+starIfUnknown (Row k) = Row (starIfUnknown k)
starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
starIfUnknown k = k
@@ -124,10 +128,6 @@ starIfUnknown k = k
-- Infer a kind for a type
--
infer :: Type -> UnifyT Kind Check Kind
-infer (Object row) = do
- k <- infer row
- k =?= Row Star
- return Star
infer (TypeVar v) = do
Just moduleName <- checkCurrentModule <$> get
UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 6f3427e..70ab2c4 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -20,9 +20,9 @@ module Language.PureScript.TypeChecker.Monad where
import Language.PureScript.Types
import Language.PureScript.Kinds
-import Language.PureScript.Values
import Language.PureScript.Names
import Language.PureScript.Environment
+import Language.PureScript.TypeClassDictionaries
import Data.Maybe
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index d4749fe..21cb6b6 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -48,10 +48,11 @@ import Data.Generics
something, everywhere, mkQ)
import Data.Generics.Extras
-import Language.PureScript.Values
+import Language.PureScript.Declarations
import Language.PureScript.Types
import Language.PureScript.Kinds
import Language.PureScript.Names
+import Language.PureScript.TypeClassDictionaries
import Language.PureScript.TypeChecker.Monad
import Language.PureScript.TypeChecker.Kinds
import Language.PureScript.TypeChecker.Synonyms
@@ -106,7 +107,6 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
sk `unifyTypes` ty2
unifyTypes' ForAll{} _ = throwError "Skolem variable scope is unspecified"
unifyTypes' ty f@ForAll{} = f `unifyTypes` ty
- unifyTypes' (Object row1) (Object row2) = row1 =?= row2
unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
unifyTypes' (TypeConstructor c1) (TypeConstructor c2) =
guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (c1 == c2)
@@ -163,48 +163,15 @@ unifyRows r1 r2 =
typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Value)] -> Check [(Ident, (Value, Type))]
typesOf mainModuleName moduleName vals = do
tys <- fmap tidyUp . liftUnify $ do
- let
- -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
- es = map isTyped vals
- -- Filter the typed and untyped declarations
- typed = filter (isJust . snd . snd) es
- untyped = filter (isNothing . snd . snd) es
- -- Make a map of names to typed declarations
- typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed
- -- Create fresh unification variables for the types of untyped declarations
- untypedNames <- replicateM (length untyped) fresh
- let
- -- Make a map of names to the unification variables of untyped declarations
- untypedDict = zip (map fst untyped) untypedNames
- -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
- dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
- forM es $ \e@(_, (val, _)) -> do
- -- If the declaration is a function, it has access to other values in the binding group.
- -- If not, the generated code might fail at runtime since those values might be undefined.
- let dict' = if isFunction val then dict else M.empty
- triple@(_, (_, ty)) <- case e of
- -- Typed declarations
- (ident, (val', Just (ty, checkType))) -> do
- -- Kind check
- kind <- liftCheck $ kindOf moduleName ty
- guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
- -- Check the type with the new names in scope
- ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
- val'' <- bindNames dict' $ if checkType
- then TypedValue True <$> check val' ty' <*> pure ty'
- else return (TypedValue False val' ty')
- return (ident, (val'', ty'))
- -- Untyped declarations
- (ident, (val', Nothing)) -> do
- -- Infer the type with the new names in scope
- TypedValue _ val'' ty <- bindNames dict' $ infer val'
- ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
- return (ident, (TypedValue True val'' ty, ty))
+ (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
+ forM es $ \e -> do
+ triple@(_, (_, ty)) <- typeForBindingGroupElement moduleName e dict untypedDict
-- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
when (Just moduleName == mainModuleName && fst e == Ident C.main) $ do
[eff, a] <- replicateM 2 fresh
ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
return triple
+
forM tys $ \(ident, (val, ty)) -> do
-- Replace type class dictionary placeholders with actual dictionaries
val' <- replaceTypeClassDictionaries moduleName val
@@ -219,6 +186,51 @@ typesOf mainModuleName moduleName vals = do
-- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
+typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Value)] -> UnifyT Type Check ([(Ident, (Value, Maybe (Type, Bool)))], M.Map (ModuleName, Ident) (Type, NameKind), [(Ident, Type)])
+typeDictionaryForBindingGroup moduleName vals = do
+ let
+ -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
+ es = map isTyped vals
+ -- Filter the typed and untyped declarations
+ typed = filter (isJust . snd . snd) es
+ untyped = filter (isNothing . snd . snd) es
+ -- Make a map of names to typed declarations
+ typedDict = map (\(ident, (_, Just (ty, _))) -> (ident, ty)) typed
+
+ -- Create fresh unification variables for the types of untyped declarations
+ untypedNames <- replicateM (length untyped) fresh
+
+ let
+ -- Make a map of names to the unification variables of untyped declarations
+ untypedDict = zip (map fst untyped) untypedNames
+ -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
+ dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
+ return (es, dict, untypedDict)
+
+typeForBindingGroupElement :: ModuleName -> (Ident, (Value, Maybe (Type, Bool))) -> M.Map (ModuleName, Ident) (Type, NameKind) -> [(Ident, Type)] -> UnifyT Type Check (Ident, (Value, Type))
+typeForBindingGroupElement moduleName e@(_, (val, _)) dict untypedDict = do
+ -- If the declaration is a function, it has access to other values in the binding group.
+ -- If not, the generated code might fail at runtime since those values might be undefined.
+ let dict' = if isFunction val then dict else M.empty
+ case e of
+ -- Typed declarations
+ (ident, (val', Just (ty, checkType))) -> do
+ -- Kind check
+ kind <- liftCheck $ kindOf moduleName ty
+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
+ -- Check the type with the new names in scope
+ ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
+ val'' <- bindNames dict' $ if checkType
+ then TypedValue True <$> check val' ty' <*> pure ty'
+ else return (TypedValue False val' ty')
+ return (ident, (val'', ty'))
+ -- Untyped declarations
+ (ident, (val', Nothing)) -> do
+ -- Infer the type with the new names in scope
+ TypedValue _ val'' ty <- bindNames dict' $ infer val'
+ ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
+ return (ident, (TypedValue True val'' ty, ty))
+
-- |
-- Check if a value introduces a function
--
@@ -462,6 +474,12 @@ expandTypeSynonym name args = do
env <- getEnv
either throwError return $ expandTypeSynonym' env name args
+expandAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Type -> m Type
+expandAllTypeSynonyms = everywhereM' (mkM go)
+ where
+ go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
+ go other = return other
+
-- |
-- Ensure a set of property names and value does not contain duplicate labels
--
@@ -490,7 +508,7 @@ infer' (ObjectLiteral ps) = do
ensureNoDuplicateProperties ps
ts <- mapM (infer . snd) ps
let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts
- ty = Object $ rowFromList (fields, REmpty)
+ ty = TypeApp tyObject $ rowFromList (fields, REmpty)
return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty
infer' (ObjectUpdate o ps) = do
ensureNoDuplicateProperties ps
@@ -498,9 +516,9 @@ infer' (ObjectUpdate o ps) = do
newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals
oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
- let oldTy = Object $ rowFromList (oldTys, row)
+ let oldTy = TypeApp tyObject $ rowFromList (oldTys, row)
o' <- TypedValue True <$> check o oldTy <*> pure oldTy
- return $ TypedValue True (ObjectUpdate o' newVals) $ Object $ rowFromList (newTys, row)
+ return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)
infer' (Accessor prop val) = do
typed@(TypedValue _ _ objTy) <- infer val
propTy <- inferProperty objTy prop
@@ -508,7 +526,7 @@ infer' (Accessor prop val) = do
Nothing -> do
field <- fresh
rest <- fresh
- _ <- subsumes Nothing objTy (Object (RCons prop field rest))
+ _ <- subsumes Nothing objTy (TypeApp tyObject (RCons prop field rest))
return $ TypedValue True (Accessor prop typed) field
Just ty -> return $ TypedValue True (Accessor prop typed) ty
infer' (Abs (Left arg) ret) = do
@@ -547,6 +565,9 @@ infer' (IfThenElse cond th el) = do
v3@(TypedValue _ _ t3) <- infer el
t2 =?= t3
return $ TypedValue True (IfThenElse cond' v2 v3) t2
+infer' (Let ds val) = do
+ (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
+ return $ TypedValue True (Let ds' val') valTy
infer' (TypedValue checkType val ty) = do
Just moduleName <- checkCurrentModule <$> get
kind <- liftCheck $ kindOf moduleName ty
@@ -556,11 +577,28 @@ infer' (TypedValue checkType val ty) = do
return $ TypedValue True val' ty'
infer' _ = error "Invalid argument to infer"
+inferLetBinding :: [Declaration] -> [Declaration] -> Value -> (Value -> UnifyT Type Check Value) -> UnifyT Type Check ([Declaration], Value)
+inferLetBinding seen [] ret j = (,) seen <$> j ret
+inferLetBinding seen (ValueDeclaration ident nameKind [] Nothing val : rest) ret j = do
+ valTy <- fresh
+ Just moduleName <- checkCurrentModule <$> get
+ TypedValue _ val' valTy' <- bindNames (M.singleton (moduleName, ident) (valTy, nameKind)) $ infer val
+ valTy =?= valTy'
+ bindNames (M.singleton (moduleName, ident) (valTy', nameKind)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] Nothing val']) rest ret j
+inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
+ Just moduleName <- checkCurrentModule <$> get
+ (es, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
+ ds' <- forM es $ \e -> do
+ (ident, (val', _)) <- typeForBindingGroupElement moduleName e dict untypedDict
+ return $ (ident, LocalVariable, val')
+ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
+inferLetBinding _ _ _ _ = error "Invalid argument to fromValueDeclaration"
+
-- |
-- Infer the type of a property inside a record with a given type
--
inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)
-inferProperty (Object row) prop = do
+inferProperty (TypeApp obj row) prop | obj == tyObject = do
let (props, _) = rowToList row
return $ lookup prop props
inferProperty (SaturatedTypeSynonym name args) prop = do
@@ -599,7 +637,7 @@ inferBinder val (ObjectBinder props) = do
row <- fresh
rest <- fresh
m1 <- inferRowProperties row rest props
- val =?= Object row
+ val =?= TypeApp tyObject row
return m1
where
inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Type Check (M.Map Ident Type)
@@ -703,8 +741,7 @@ check' val t@(ConstrainedType constraints ty) = do
return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
check' val (SaturatedTypeSynonym name args) = do
ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
- val' <- check val ty
- return $ TypedValue True val' ty
+ check val ty
check' val u@(TUnknown _) = do
val'@(TypedValue _ _ ty) <- infer val
-- Don't unify an unknown with an inferred polytype
@@ -759,22 +796,22 @@ check' (IfThenElse cond th el) ty = do
th' <- check th ty
el' <- check el ty
return $ TypedValue True (IfThenElse cond' th' el') ty
-check' (ObjectLiteral ps) t@(Object row) = do
+check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do
ensureNoDuplicateProperties ps
ps' <- checkProperties ps row False
return $ TypedValue True (ObjectLiteral ps') t
-check' (ObjectUpdate obj ps) t@(Object row) = do
+check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do
ensureNoDuplicateProperties ps
us <- zip (map fst ps) <$> replicateM (length ps) fresh
let (propsToCheck, rest) = rowToList row
propsToRemove = map fst ps
remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck
- obj' <- check obj (Object (rowFromList (us ++ remainingProps, rest)))
+ obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))
ps' <- checkProperties ps row True
return $ TypedValue True (ObjectUpdate obj' ps') t
check' (Accessor prop val) ty = do
rest <- fresh
- val' <- check val (Object (RCons prop ty rest))
+ val' <- check val (TypeApp tyObject (RCons prop ty rest))
return $ TypedValue True (Accessor prop val') ty
check' (Constructor c) ty = do
env <- getEnv
@@ -784,8 +821,19 @@ check' (Constructor c) ty = do
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
_ <- subsumes Nothing repl ty
return $ TypedValue True (Constructor c) ty
+check' (Let ds val) ty = do
+ (ds', val') <- inferLetBinding [] ds val (flip check ty)
+ return $ TypedValue True (Let ds' val') ty
+check' val ty | containsTypeSynonyms ty = do
+ ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty
+ check val ty'
check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
+containsTypeSynonyms :: Type -> Bool
+containsTypeSynonyms = everything (||) (mkQ False go) where
+ go (SaturatedTypeSynonym _ _) = True
+ go _ = False
+
-- |
-- Check the type of a collection of named record fields
--
@@ -818,7 +866,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
v' <- check v ty
ps'' <- go ps' (delete (p, ty) ts) r
return $ (p, v') : ps''
- go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
+ go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (TypeApp tyObject row)
-- |
-- Check the type of a function application, rethrowing errors to provide a better error message
@@ -903,7 +951,7 @@ subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
dicts <- getTypeClassDictionaries
_ <- subsumes' Nothing ty1 ty2
return . Just $ foldl App val (map (flip TypeClassDictionary dicts) constraints)
-subsumes' val (Object r1) (Object r2) = do
+subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do
let
(ts1, r1') = rowToList r1
(ts2, r2') = rowToList r2
@@ -923,7 +971,7 @@ subsumes' val (Object r1) (Object r2) = do
| otherwise = do rest <- fresh
r1' =?= RCons p2 ty2 rest
go ((p1, ty1) : ts1) ts2 rest r2'
-subsumes' val ty1 ty2@(Object _) = subsumes val ty2 ty1
+subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1
subsumes' val ty1 ty2 = do
ty1 =?= ty2
return val
diff --git a/src/Language/PureScript/TypeClassDictionaries.hs b/src/Language/PureScript/TypeClassDictionaries.hs
new file mode 100644
index 0000000..35001c7
--- /dev/null
+++ b/src/Language/PureScript/TypeClassDictionaries.hs
@@ -0,0 +1,62 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Language.PureScript.TypeClassDictionaries
+-- Copyright : (c) 2014 Phil Freeman
+-- License : MIT
+--
+-- Maintainer : Phil Freeman <paf31@cantab.net>
+-- Stability : experimental
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Language.PureScript.TypeClassDictionaries where
+
+import Data.Data
+
+import Language.PureScript.Names
+import Language.PureScript.Types
+
+-- |
+-- Data representing a type class dictionary which is in scope
+--
+data TypeClassDictionaryInScope
+ = TypeClassDictionaryInScope {
+ -- |
+ -- The identifier with which the dictionary can be accessed at runtime
+ --
+ tcdName :: Qualified Ident
+ -- |
+ -- The name of the type class to which this type class instance applies
+ --
+ , tcdClassName :: Qualified ProperName
+ -- |
+ -- The types to which this type class instance applies
+ --
+ , tcdInstanceTypes :: [Type]
+ -- |
+ -- Type class dependencies which must be satisfied to construct this dictionary
+ --
+ , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]
+ -- |
+ -- The type of this dictionary
+ --
+ , tcdType :: TypeClassDictionaryType
+ } deriving (Show, Data, Typeable)
+
+-- |
+-- The type of a type class dictionary
+--
+data TypeClassDictionaryType
+ -- |
+ -- A regular type class dictionary
+ --
+ = TCDRegular
+ -- |
+ -- A type class dictionary which is an alias for an imported dictionary from another module
+ --
+ | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index a7b49c2..c314f36 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -40,10 +40,6 @@ data Type
--
= TUnknown Unknown
-- |
- -- Javascript numbers
- --
- | Object Type
- -- |
-- A named type variable
--
| TypeVar String
@@ -90,6 +86,10 @@ data Type
-- |
-- A placeholder used in pretty printing
--
+ | PrettyPrintObject Type
+ -- |
+ -- A placeholder used in pretty printing
+ --
| PrettyPrintForAll [String] Type deriving (Show, Eq, Data, Typeable)
-- |
@@ -121,12 +121,6 @@ mkForAll :: [String] -> Type -> Type
mkForAll args ty = foldl (\t arg -> ForAll arg t Nothing) ty args
-- |
--- The empty record type
---
-unit :: Type
-unit = Object REmpty
-
--- |
-- Replace a type variable, taking into account variable shadowing
--
replaceTypeVars :: String -> Type -> Type -> Type
@@ -135,7 +129,6 @@ replaceTypeVars = replaceTypeVars' []
replaceTypeVars' bound name replacement = go bound
where
go :: [String] -> Type -> Type
- go bs (Object r) = Object $ go bs r
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
@@ -176,7 +169,6 @@ freeTypeVariables :: Type -> [String]
freeTypeVariables = nub . go []
where
go :: [String] -> Type -> [String]
- go bound (Object r) = go bound r
go bound (TypeVar v) | v `notElem` bound = [v]
go bound (TypeApp t1 t2) = go bound t1 ++ go bound t2
go bound (SaturatedTypeSynonym _ ts) = concatMap (go bound) ts
diff --git a/src/Language/PureScript/Values.hs b/src/Language/PureScript/Values.hs
deleted file mode 100644
index 29ba4ae..0000000
--- a/src/Language/PureScript/Values.hs
+++ /dev/null
@@ -1,254 +0,0 @@
------------------------------------------------------------------------------
---
--- Module : Language.PureScript.Values
--- Copyright : (c) Phil Freeman 2013
--- License : MIT
---
--- Maintainer : Phil Freeman <paf31@cantab.net>
--- Stability : experimental
--- Portability :
---
--- |
--- Data types for values, statements, binders and do notation
---
------------------------------------------------------------------------------
-
-{-# LANGUAGE DeriveDataTypeable #-}
-
-module Language.PureScript.Values where
-
-import Language.PureScript.Types
-import Language.PureScript.Names
-
-import Data.Data
-import Data.Generics (mkQ, everything)
-
--- |
--- A guard is just a boolean-valued expression that appears alongside a set of binders
---
-type Guard = Value
-
--- |
--- Data type for values
---
-data Value
- -- |
- -- A numeric literal
- --
- = NumericLiteral (Either Integer Double)
- -- |
- -- A string literal
- --
- | StringLiteral String
- -- |
- -- A boolean literal
- --
- | BooleanLiteral Bool
- -- |
- -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
- -- will be removed.
- --
- | BinaryNoParens (Qualified Ident) Value Value
- -- |
- -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
- -- will be removed.
- --
- | Parens Value
- -- |
- -- An array literal
- --
- | ArrayLiteral [Value]
- -- |
- -- An object literal
- --
- | ObjectLiteral [(String, Value)]
- -- |
- -- An record property accessor expression
- --
- | Accessor String Value
- -- |
- -- Partial record update
- --
- | ObjectUpdate Value [(String, Value)]
- -- |
- -- Function introduction
- --
- | Abs (Either Ident Binder) Value
- -- |
- -- Function application
- --
- | App Value Value
- -- |
- -- Variable
- --
- | Var (Qualified Ident)
- -- |
- -- Conditional (if-then-else expression)
- --
- | IfThenElse Value Value Value
- -- |
- -- A data constructor
- --
- | Constructor (Qualified ProperName)
- -- |
- -- A case expression. During the case expansion phase of desugaring, top-level binders will get
- -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
- --
- | Case [Value] [CaseAlternative]
- -- |
- -- A value with a type annotation
- --
- | TypedValue Bool Value Type
- -- |
- -- A let binding
- --
- | Let (Either Binder (Ident, [Either Ident Binder])) Value Value
- -- |
- -- A do-notation block
- --
- | Do [DoNotationElement]
- -- |
- -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
- -- placeholders will be replaced with actual expressions representing type classes dictionaries which
- -- can be evaluated at runtime. The constructor arguments represent (in order): the type class name and
- -- instance type, and the type class dictionaries in scope.
- --
- | TypeClassDictionary (Qualified ProperName, [Type]) [TypeClassDictionaryInScope] deriving (Show, Data, Typeable)
-
--- |
--- An alternative in a case statement
---
-data CaseAlternative = CaseAlternative
- { -- |
- -- A collection of binders with which to match the inputs
- --
- caseAlternativeBinders :: [Binder]
- -- |
- -- An optional guard
- --
- , caseAlternativeGuard :: Maybe Guard
- -- |
- -- The result expression
- --
- , caseAlternativeResult :: Value
- } deriving (Show, Data, Typeable)
-
--- |
--- Data representing a type class dictionary which is in scope
---
-data TypeClassDictionaryInScope
- = TypeClassDictionaryInScope {
- -- |
- -- The identifier with which the dictionary can be accessed at runtime
- --
- tcdName :: Qualified Ident
- -- |
- -- The name of the type class to which this type class instance applies
- --
- , tcdClassName :: Qualified ProperName
- -- |
- -- The types to which this type class instance applies
- --
- , tcdInstanceTypes :: [Type]
- -- |
- -- Type class dependencies which must be satisfied to construct this dictionary
- --
- , tcdDependencies :: Maybe [(Qualified ProperName, [Type])]
- -- |
- -- The type of this dictionary
- --
- , tcdType :: TypeClassDictionaryType
- } deriving (Show, Data, Typeable)
-
--- |
--- The type of a type class dictionary
---
-data TypeClassDictionaryType
- -- |
- -- A regular type class dictionary
- --
- = TCDRegular
- -- |
- -- A type class dictionary which is an alias for an imported dictionary from another module
- --
- | TCDAlias (Qualified Ident) deriving (Show, Eq, Data, Typeable)
-
--- |
--- Find the original dictionary which a type class dictionary in scope refers to
---
-canonicalizeDictionary :: TypeClassDictionaryInScope -> Qualified Ident
-canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDRegular, tcdName = nm }) = nm
-canonicalizeDictionary (TypeClassDictionaryInScope { tcdType = TCDAlias nm }) = nm
-
--- |
--- A statement in a do-notation block
---
-data DoNotationElement
- -- |
- -- A monadic value without a binder
- --
- = DoNotationValue Value
- -- |
- -- A monadic value with a binder
- --
- | DoNotationBind Binder Value
- -- |
- -- A let statement, i.e. a pure value with a binder
- --
- | DoNotationLet Binder Value deriving (Show, Data, Typeable)
-
--- |
--- Data type for binders
---
-data Binder
- -- |
- -- Wildcard binder
- --
- = NullBinder
- -- |
- -- A binder which matches a boolean literal
- --
- | BooleanBinder Bool
- -- |
- -- A binder which matches a string literal
- --
- | StringBinder String
- -- |
- -- A binder which matches a numeric literal
- --
- | NumberBinder (Either Integer Double)
- -- |
- -- A binder which binds an identifier
- --
- | VarBinder Ident
- -- |
- -- A binder which matches a data constructor
- --
- | ConstructorBinder (Qualified ProperName) [Binder]
- -- |
- -- A binder which matches a record and binds its properties
- --
- | ObjectBinder [(String, Binder)]
- -- |
- -- A binder which matches an array and binds its elements
- --
- | ArrayBinder [Binder]
- -- |
- -- A binder which matches an array and binds its head and tail
- --
- | ConsBinder Binder Binder
- -- |
- -- A binder which binds its input to an identifier
- --
- | NamedBinder Ident Binder deriving (Show, Data, Typeable)
-
-
--- |
--- Collect all names introduced in binders in an expression
---
-binderNames :: (Data d) => d -> [Ident]
-binderNames = everything (++) (mkQ [] go)
- where
- go (VarBinder ident) = [ident]
- go (NamedBinder ident _) = [ident]
- go _ = []