packages feed

purescript 0.4.8 → 0.4.9

raw patch · 40 files changed

+862/−783 lines, 40 files

Files

prelude/prelude.purs view
@@ -139,24 +139,38 @@     (%) = 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 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
psc-make/Main.hs view
@@ -91,9 +91,9 @@ 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 = 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 @@      { 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
psc/Main.hs view
@@ -86,9 +86,9 @@ 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 = 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 @@      { 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
psci/Main.hs view
@@ -161,7 +161,6 @@  -- | -- 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 @@ -- | 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.
psci/Parser.hs view
@@ -26,6 +26,7 @@ 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 @@ -- 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.
purescript.cabal view
@@ -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 @@                      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 @@                      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 @@                      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
src/Language/PureScript.hs view
@@ -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 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' :: 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 @@   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 @@ -- 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 @@   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 @@   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
src/Language/PureScript/CodeGen/Externs.hs view
@@ -24,10 +24,10 @@  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  -- |
src/Language/PureScript/CodeGen/JS.hs view
@@ -30,7 +30,6 @@  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 (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 @@   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
src/Language/PureScript/DeadCodeElimination.hs view
@@ -23,7 +23,6 @@ import Data.Maybe (mapMaybe)  import Language.PureScript.Names-import Language.PureScript.Values import Language.PureScript.Declarations  -- |
src/Language/PureScript/Declarations.hs view
@@ -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 @@ -- | -- 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 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 _ = []
src/Language/PureScript/Environment.hs view
@@ -21,7 +21,7 @@ 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 = primTy "Array"  -- |+-- Type constructor for objects+--+tyObject :: Type+tyObject = primTy "Object"++-- | -- Smart constructor for function types -- function :: Type -> Type -> Type@@ -183,6 +189,7 @@ 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)) ]
src/Language/PureScript/ModuleDependencies.hs view
@@ -67,4 +67,4 @@ 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)
src/Language/PureScript/Optimizer/MagicDo.hs view
@@ -30,8 +30,8 @@ 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 @@   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 @@   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 @@   -- 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 =
src/Language/PureScript/Optimizer/TCO.hs view
@@ -24,8 +24,8 @@ -- 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)
src/Language/PureScript/Options.hs view
@@ -20,17 +20,21 @@ -- 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 @@ -- Default compiler options -- defaultOptions :: Options-defaultOptions = Options False False False Nothing False "PS" [] []+defaultOptions = Options False False False False Nothing False "PS" [] []
src/Language/PureScript/Parser.hs view
@@ -29,7 +29,6 @@  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
src/Language/PureScript/Parser/Common.hs view
@@ -36,6 +36,7 @@                   , "import"                   , "infixl"                   , "infixr"+                  , "infix"                   , "class"                   , "instance"                   , "module"@@ -226,8 +227,14 @@ -- 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
src/Language/PureScript/Parser/Declarations.hs view
@@ -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 @@                          <*> (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 @@ 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,8 +171,15 @@                    , 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 @@ -- 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++
src/Language/PureScript/Parser/Types.hs view
@@ -49,7 +49,7 @@ 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
− src/Language/PureScript/Parser/Values.hs 
@@ -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-
src/Language/PureScript/Pretty/Types.hs view
@@ -34,8 +34,8 @@ 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 @@   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 @@   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
src/Language/PureScript/Pretty/Values.hs view
@@ -24,7 +24,7 @@ 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 @@   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"
src/Language/PureScript/Scope.hs view
@@ -24,7 +24,7 @@ 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
src/Language/PureScript/Sugar.hs view
@@ -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.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 @@ -- desugar :: [Module] -> Either String [Module] desugar = desugarDo-          >=> desugarLetBindings-          >>> desugarCasesModule+          >=> desugarCasesModule+          >=> desugarTypeDeclarationsModule           >=> desugarImports           >=> rebracket-          >=> desugarTypeDeclarationsModule           >=> desugarTypeClasses           >=> createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hs view
@@ -24,13 +24,13 @@ 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 @@ -- 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,15 +68,25 @@            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)
src/Language/PureScript/Sugar/CaseDeclarations.hs view
@@ -20,14 +20,14 @@ ) 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 @@     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 []
src/Language/PureScript/Sugar/DoNotation.hs view
@@ -21,9 +21,9 @@ 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
− src/Language/PureScript/Sugar/Let.hs 
@@ -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
src/Language/PureScript/Sugar/Names.hs view
@@ -16,6 +16,7 @@   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 Language.PureScript.Declarations import Language.PureScript.Names import Language.PureScript.Types-import Language.PureScript.Values import Language.PureScript.Environment  -- |@@ -134,10 +134,9 @@ -- 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 @@     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 @@ -- 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 @@     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)))
src/Language/PureScript/Sugar/Operators.hs view
@@ -25,7 +25,6 @@  import Language.PureScript.Names import Language.PureScript.Declarations-import Language.PureScript.Values  import Control.Applicative import Control.Monad.State@@ -107,6 +106,7 @@ 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 ""))
src/Language/PureScript/Sugar/TypeClasses.hs view
@@ -22,7 +22,6 @@ 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 @@  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 @@                    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'
src/Language/PureScript/Sugar/TypeDeclarations.hs view
@@ -19,12 +19,14 @@     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 (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 []
src/Language/PureScript/TypeChecker.hs view
@@ -32,9 +32,9 @@  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 _ _ [] = 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 @@   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
src/Language/PureScript/TypeChecker/Kinds.hs view
@@ -67,13 +67,13 @@ -- | -- 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 @@         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 @@ -- | -- 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 @@ -- 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 @@ -- 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))
src/Language/PureScript/TypeChecker/Monad.hs view
@@ -20,9 +20,9 @@  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
src/Language/PureScript/TypeChecker/Types.hs view
@@ -48,10 +48,11 @@         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 @@     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 @@ 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 @@   -- 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 @@   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 @@   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 @@   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 @@     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 @@   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 @@   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 @@   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 @@   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 @@   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 @@       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 @@         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 @@   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 @@     | 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
+ src/Language/PureScript/TypeClassDictionaries.hs view
@@ -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)
src/Language/PureScript/Types.hs view
@@ -40,10 +40,6 @@   --   = TUnknown Unknown   -- |-  -- Javascript numbers-  ---  | Object Type-  -- |   -- A named type variable   --   | TypeVar String@@ -90,6 +86,10 @@   -- |   -- 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 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' 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 = 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
− src/Language/PureScript/Values.hs 
@@ -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 _ = []